module modConvParGF !! GF Convective parameterization !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! This convective parameterization is build to attempt !! a smooth transition to cloud resolving scales as proposed !! by Arakawa et al (2011, ACP). The scheme is described !! in the paper Grell and Freitas (ACP, 2014). !! !! Implemented in GEOS5 GCM by Saulo Freitas (July 2016) !! Use the following references for this implementation: !! Freitas et al (2018, JAMES/AGU, https://doi.org/10.1029/2017MS001251) !! Freitas et al (2021, GMD/EGU, https://doi.org/10.5194/gmd-14-5393-2021) !! Please, contact Saulo Freitas (saulo.r.de.freitas@gmail.com) for comments !! questions, bugs, etc. !! !! Adapted for BRAMS 6.0 by Saulo Freitas (November 2021) !! Refactoring by Luiz Flavio Rodrigues at 20 December 2021 (Monday) !! Keywords using ; are separeted, some loops receives exit instead goto, !! The identation was fixed and all keywords are lowercase !! !! Refactoring by GCC (INPE) at 20 January 2023 using fprettify and manual !! changes according MONAN rules code patterns DTN 01 !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, but !! WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the, GNU !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see <https://www.gnu.org/licenses/>. !! !! @endwarning use modGate, only: cupout & , rundata & , p_nvar_grads & , runlabel & , runname & , jl & , p_use_gate & , ppres & , ptemp & , pq & , pu & , pv & , pvervel & , pgeo & , zqr & , zadvq & , zadvt use modHenrysLawConstants, only: getHenryLawCts implicit none include 'constants.h' character(len=*), parameter :: source_name = 'modConvParGF.F90' ! Nome do arquivo fonte character(len=*), parameter :: module_name = 'modConvParGF' ! Nome do módulo private public p_maxiens, ICUMULUS_GF, CLOSURE_CHOICE, p_deep, p_shal, p_mid & , USE_SCALE_DEP, DICYCLE, TAU_DEEP, TAU_MID, hcts & , USE_TRACER_TRANSP, USE_TRACER_SCAVEN, USE_MEMORY, CONVECTION_TRACER & , USE_FLUX_FORM, USE_TRACER_EVAP, DOWNDRAFT, USE_FCT & , USE_REBCB, VERT_DISCR, SATUR_CALC, CLEV_GRID, APPLY_SUB_MP, ALP1 & , SGS_W_TIMESCALE, LIGHTNING_DIAG, TAU_OCEA_CP, TAU_LAND_CP & , AUTOCONV, BC_METH, OVERSHOOT, USE_WETBULB & , C1, C0_DEEP, QRC_CRIT, LAMBAU_DEEP, LAMBAU_SHDN, C0_MID & , CUM_MAX_EDT_LAND, CUM_MAX_EDT_OCEAN, CUM_HEI_DOWN_LAND & , CUM_HEI_DOWN_OCEAN, CUM_HEI_UPDF_LAND, CUM_HEI_UPDF_OCEAN & , USE_MOMENTUM_TRANSP, CUM_ENTR_RATE & , p_nmp, p_lsmp, p_cnmp, MOIST_TRIGGER, FRAC_MODIS, MAX_TQ_TEND & , CUM_FADJ_MASSFLX, CUM_USE_EXCESS, CUM_AVE_LAYER, ADV_TRIGGER & , USE_SMOOTH_PROF, output_sound, USE_CLOUD_DISSIPATION & , USE_SMOOTH_TEND, gfConparInit, BETA_SH, C0_SHAL & , USE_LINEAR_SUBCL_MF, CAP_MAXS, LIQ_ICE_NUMBER_CONC, ALPHA_ADV_TUNING & , SIG_FACTOR, LCL_TRIGGER, RH_DICYCLE, ADD_COLDPOOL_PROP & , ADD_COLDPOOL_CLOS, MX_BUOY1, MX_BUOY2, CUM_T_STAR, CUM_ZUFORM & , ADD_COLDPOOL_DIFF public modConvParGFDriver, MakeDropletNumber, MakeIceNumber, FractLiqF & , USE_GUSTINESS, USE_RANDOM_NUM, DCAPE_THRESHOLD, ColdPoolStart public modConvParGF_initialized, initModConvParGF !================================================= ! module parameters !================================================= integer, parameter :: p_maxiens = 3 !! plume spectral size integer, parameter :: p_deep = 1 !! plume spectral size integer, parameter :: p_shal = 2 !! plume spectral size integer, parameter :: p_mid = 3 !! plume spectral size character(len=10), parameter, dimension(p_maxiens) :: p_cumulus_type = (/ & 'deep ' & , 'shallow ' & , 'mid ' & /) !! Cumulus type integer, parameter :: p_nmp = 2 !! number of microphysics schemes in the host model integer, parameter :: p_lsmp = 1 !! number of microphysics schemes in the host model integer, parameter :: p_cnmp = 2 !! number of microphysics schemes in the host model !-- General internal controls for the diverse options in GF logical, parameter :: p_entr_new = .true. !! new entr formulation logical, parameter :: p_coupl_mphysics = .true. !! coupling with cloud microphysics (do not change to false) logical, parameter :: p_melt_glac = .true. !! turn ON/OFF ice phase/melting logical, parameter :: p_feed_3D_model = .true. !! set "false" to not feedback the AGCM with the !! heating/drying/transport conv tendencies integer, parameter :: p_aeroevap = 1 !! rainfall evaporation (1) orig - (2) mix orig+new - (3) new integer, parameter :: p_maxens = 1 ! ensemble one on cap_max integer, parameter :: p_maxens2 = 1 ! ensemble two on precip efficiency integer, parameter :: p_maxens3 = 16 !ensemble three done in cup_forcing_ens16 for G3d integer, parameter :: p_ensdim = p_maxens*p_maxens2*p_maxens3 !! integer, parameter :: p_ens4 = 1 !! real, parameter :: p_pgcon = 0.0 !! proportionality constant to estimate pressure !! gradient of updraft (Zhang and Wu, 2003, JAS) => REAL, PARAMETER :: pgcon=-0.55 !- numerical constraints real, parameter :: p_xmbmaxshal = 0.05 !! kg/m2/s real, parameter :: p_mintracer = tiny(1.) !! kg/kg - tiny(x) real, parameter :: p_smallerqv = 1.e-16 !! kg/kg integer, parameter :: p_max_n_spec = 200 !! integer, parameter :: p_shall_closures = 12 !! integer, parameter :: p_on = 1 !! ON integer paremeters integer, parameter :: p_off = 0 !! OFF integer paremeters !================================================= ! End of module parameters !================================================= !================================================= ! namelist variables !================================================= real :: CUM_ENTR_RATE(p_maxiens) !!-- gross entraiment rate: deep, shallow, congestus real :: ALP1 !! 0/0.5/1: apply subsidence transport of LS/anvil cloud fraction using !! time implicit discretization real :: TAU_DEEP !! deep convective timescale real :: TAU_MID !! congestus convective timescale real :: MAX_TQ_TEND !! max T,Q tendency allowed (100 K/day) real :: OVERSHOOT !! 0, 1 real :: C0_DEEP !! default= 3.e-3 conversion rate (cloud to rain, m-1) - for deep plume real :: C0_MID !! default= 2.e-3 conversion rate (cloud to rain, m-1) - for congestus plume real :: C0_SHAL !! default= 0.e-3 conversion rate (cloud to rain, m-1) - for shallow plume real :: QRC_CRIT !! default= 2.e-4 kg/kg real :: C1 !! default= 1.e-3 conversion rate (cloud to rain, m-1) - for the 'C1d' detrainment approach real :: LAMBAU_DEEP !! default= 2.0 lambda parameter for deep/congestus convection momentum transp real :: LAMBAU_SHDN !! default= 2.0 lambda parameter for shallow/downdraft convection momentum transp real :: CUM_HEI_DOWN_LAND(p_maxiens) !! [0.2,0.8] height of the max Z Downdraft , default = 0.50 real :: CUM_HEI_DOWN_OCEAN(p_maxiens) !! [0.2,0.8] height of the max Z Downdraft , default = 0.50 real :: CUM_HEI_UPDF_LAND(p_maxiens) !! [0.2,0.8] height of the max Z Updraft , default = 0.35 real :: CUM_HEI_UPDF_OCEAN(p_maxiens) !! [0.2,0.8] height of the max Z Updraft , default = 0.35 real :: CUM_MAX_EDT_LAND(p_maxiens) !! maximum evap fraction allowed over the land ,default= 0.9 real :: CUM_MAX_EDT_OCEAN(p_maxiens) !! maximum evap fraction allowed over the ocean ,default= 0.9 real :: CUM_FADJ_MASSFLX(p_maxiens) !! multiplicative factor for tunning the mass flux at cloud base != default = 1.0 real :: CUM_T_STAR(p_maxiens) !! scale temperature for the diurnal cycle closure real :: CUM_AVE_LAYER(p_maxiens) !! layer depth for average the properties !! of source air parcels (mbar) = (/15., -99., -99./) !! scale temperature for the diurnal cycle closure real :: DCAPE_THRESHOLD !! CAPE time rate threshold for ADV_TRIGGER = 1 (J kg^-1 hr^-1) !! typical range is [-200,200] J/kg/hr, Wu et all (2007) recomends ~ 70 J/kg/hr !! 55 J/kg/hr is indicated for the Amazon basin (Song&Zhang 2017) real :: TAU_OCEA_CP !! real :: TAU_LAND_CP !! real :: MX_BUOY1 !! 250.5 J/kg real :: MX_BUOY2 != 20004.0 J/kg: temp exc=10 K, q deficit=4 g/kg (=> mx_buoy ~ 20 kJ/kg) real :: USE_CLOUD_DISSIPATION !! to acccount for the cloud dissipation at the decayment phase real :: USE_RANDOM_NUM !! stochastic pertubation for the height of maximum Zu real :: BETA_SH !! only for shallow plume real :: ALPHA_ADV_TUNING !! tuning parameter for the Becker et al (2021) closure real :: SIG_FACTOR !! exponential factor for the sigma determination (orig = 0.1) real :: CAP_MAXS !! max distance (hPa) the air parcel is allowed to go up looking for the LFC integer :: ICUMULUS_GF(p_maxiens) !!-- plume to be activated (1 true, 0 false): deep, shallow, congestus integer :: CLOSURE_CHOICE(p_maxiens) !! deep, shallow, congestus !!-- choice for the closures: !!-- deep : 0 ensemble (all) , 1 GR, 4 ll omega, 7 moist conv, 10 PB !!-- shallow: 0 ensemble (all) , 1 Wstar, 4 heat-engine, 7 BLQE, 10 TKE-based !!-- mid : 0 ensemble (Wstar/BLQE/PB), 1 Wstar, 2 BLQE, 3 PB, 4 PB_BL integer :: CUM_ZUFORM(p_maxiens) !!-- zu updraft format : deep, shallow, congestus !! for deep: 10 or 20, congestus: 20 integer :: USE_TRACER_TRANSP != 0/1 - default 1 integer :: USE_TRACER_SCAVEN !! 0/1/2/3 - default 2 integer :: USE_FLUX_FORM !! 1/2/3 - default 1 integer :: USE_FCT !! 0/1 - default 1 (only for USE_FLUX_FORM = 2) integer :: USE_TRACER_EVAP !! 0/1 - default 1 (only for USE_TRACER_SCAVEN > 0) integer :: CONVECTION_TRACER !! 0/1: turn ON/OFF the "convection" tracer integer :: USE_MEMORY !! -1/0/1/2 .../10 !- integer :: ADD_COLDPOOL_PROP !! -1,0,1,2,3 add coldpool propagation integer :: ADD_COLDPOOL_CLOS !! add the kinetic energy at leading of the gust front integer :: ADD_COLDPOOL_DIFF !! add vert/horizontal diffusion to the cold pool propaga integer :: USE_SCALE_DEP !! 0/1: scale dependence flag, default = 1 integer :: DICYCLE !! 0/1/2: diurnal cycle closure, default = 1 !! 2 uses Qadv closure (Becker et al 2021) integer :: RH_DICYCLE !! controls of RH on the diurnal cycle (see Tian et al 2022 GRL) integer :: CLEV_GRID !! 0/1/2: interpolation method to define environ state at the !! cloud levels (at face layer), default = 0 !! CLEV_GRID = 0 default method !! CLEV_GRID = 1 interpolation method based on Tiedtke (1989) !! CLEV_GRID = 2 for GATE soundings only integer :: USE_REBCB !! 0/1: turn ON/OFF rainfall evap below cloud base, default = 0 integer :: VERT_DISCR !! 0/1: 1=new vert discretization, default = 0 integer :: SATUR_CALC !! 0/1: 1=new saturation specific humidity calculation, default = 0 integer :: SGS_W_TIMESCALE !! 0/1: vertical velocity for tau_ecmwf, default = 0 integer :: LIGHTNING_DIAG !! 0/1: do LIGHTNING_DIAGgnostics based on Lopez (2016, MWR) integer :: APPLY_SUB_MP !! 0/1: subsidence transport applied the to grid-scale/anvil ice/liq mix !! ratio and cloud fraction integer :: USE_WETBULB !! 0/1 integer :: BC_METH !! boundary condition determination for the plumes !! 0: simple arithmetic mean around the source level !! 1: mass weighted mean around the source level integer :: AUTOCONV !! 1, 3 or 4 autoconversion formulation: (1) Kessler, !! (3) Kessler with temp dependence, (4) Sundvisqt integer :: USE_MOMENTUM_TRANSP !! 0/1: turn ON/OFF conv transp of momentum integer :: DOWNDRAFT !! 0/1: turn ON/OFF downdrafts, default = 1 integer :: USE_SMOOTH_PROF !! 1 makes the normalized mass flux, entr and detraiment profiles smoother integer :: USE_SMOOTH_TEND !! 0 => OFF, > 0 produces smoother tendencies (e.g.: for 1=> makes average between k-1,k,k+1) !! deep, shallow, congestus integer :: CUM_USE_EXCESS(p_maxiens) !! use T,Q excess sub-grid scale variability integer :: MOIST_TRIGGER !! relative humidity effects on the cap_max trigger function integer :: FRAC_MODIS !! use fraction liq/ice content derived from MODIS/CALIPO sensors integer :: ADV_TRIGGER !! dcape trigger integer :: LCL_TRIGGER !! greater than zero, activates the LCL trigger which requires the lcl height !! be lower than the pbl height, only for shallow convection integer :: USE_GUSTINESS !! not in use integer :: USE_LINEAR_SUBCL_MF !! only for shallow plume integer :: LIQ_ICE_NUMBER_CONC !! include drop/ice number mixing ratio convective tendencies !================================================= ! End of namelist variables !================================================= !================================================= ! module internal variables - !================================================= real :: hei_down_land !! [0.2,0.8] height of the max Z Downdraft , default = 0.50 real :: hei_down_ocean !! [0.2,0.8] height of the max Z Downdraft , default = 0.50 real :: hei_updf_land !! [0.2,0.8] height of the max Z Updraft , default = 0.35 real :: hei_updf_ocean !! [0.2,0.8] height of the max Z Updraft , default = 0.35 real :: max_edt_land !! default= 0.9 - maximum evap fraction allowed over the land real :: max_edt_ocean !! default= 0.9 - maximum evap fraction allowed over the ocean real :: fadj_massflux !! default= 1.0 - multiplicative factor for the mass flux at cloud base real :: temp_star !! Scale Temperature for the DC closure real :: ave_layer !! layer depth for average the properties of source air parcels (mbar) real :: c0 !! autoconversion constant real :: col_sat_adv_threshold !! suppress Qadv closure for col_sat_adv > col_sat_adv_threshold real :: chem_adj_autoc(p_max_n_spec) !! real :: time_in !! real :: int_time !! integer :: ispc_co !! integer :: whoami_all !! integer :: jcol !! integer :: itime1_in !! integer :: nrec !! integer :: ntimes !! integer :: use_excess !! default= 1 - use T,Q excess sub-grid scale variability integer :: output_sound !! outputs a "GEOS" vertical profile for the GF stand alone model integer :: ind_chem(p_max_n_spec) !! integer :: chem_name_mask(p_max_n_spec) !! integer :: chem_name_mask_evap(p_max_n_spec) !! logical :: use_c1d !! turn ON/OFF the 'c1d' detrainment approach, don't change this. logical :: first_guess_w !! use it to calculate a 1st guess of the updraft vert velocity logical :: wrtgrads !! character(len=100) :: chem_name(p_max_n_spec) !! type t_hcts_vars real :: hstar !! real :: dhr !! real :: ak0 !! real :: dak !! end type t_hcts_vars type(t_hcts_vars), allocatable :: hcts(:) !! logical :: modConvParGF_initialized !================================================= ! End of module internal variables - !================================================= contains function initModConvParGF() result(is_init) !! Initialize all variables from module !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Rodrigues, L.F. [LFR] !! **e-mail**: <mailto:luiz.rodrigues@inpe.br> !! **Date**: 26Janeiro2023 16:41 !! !! **Full description**: !! Initialize all variables from module !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'initModConvParGF' ! Nome da função !Local variables: integer :: is_init !Code: ! Se o módulo já foi inicializado retorna -1 if(modConvParGF_initialized) then is_init = -1 return endif !Inicializa as variáveis do módulo ICUMULUS_GF = (/1, 1, 1/) !ok CLOSURE_CHOICE = (/0, 7, 3/) CUM_ENTR_RATE = (/ & 9.00e-4 & !deep , 1.00e-3 & !shallow , 5.00e-4 & !mid /) CUM_ZUFORM = (/20, 20, 20/) USE_TRACER_TRANSP = 1 USE_TRACER_SCAVEN = 2 USE_FLUX_FORM = 1 USE_FCT = 1 USE_TRACER_EVAP = 1 CONVECTION_TRACER = 0 USE_MEMORY = 2 ADD_COLDPOOL_PROP = 3 ADD_COLDPOOL_CLOS = 2 ADD_COLDPOOL_DIFF = 3 USE_SCALE_DEP = 1 DICYCLE = 1 RH_DICYCLE = 0 CLEV_GRID = 1 USE_REBCB = 1 VERT_DISCR = 1 SATUR_CALC = 1 SGS_W_TIMESCALE = 1 LIGHTNING_DIAG = 0 APPLY_SUB_MP = 0 ALP1 = 1 USE_WETBULB = 0 BC_METH = 1 OVERSHOOT = 0. AUTOCONV = 1 C0_DEEP = 1.0e-3 C0_MID = 1.5e-3 C0_SHAL = 0. QRC_CRIT = 6.e-4 C1 = 0.0 USE_MOMENTUM_TRANSP = 1 LAMBAU_DEEP = 0.0 LAMBAU_SHDN = 2.0 DOWNDRAFT = 1 TAU_DEEP = 3600. TAU_MID = 1200. MAX_TQ_TEND = 300. USE_SMOOTH_PROF = 1 USE_SMOOTH_TEND = 1 CUM_HEI_DOWN_LAND = (/0.40, 0.00, 0.35/) CUM_HEI_DOWN_OCEAN = (/0.35, 0.00, 0.35/) CUM_HEI_UPDF_LAND = (/0.55, 0.10, 0.55/) CUM_HEI_UPDF_OCEAN = (/0.55, 0.10, 0.55/) CUM_MAX_EDT_LAND = (/0.60, 0.00, 0.20/) CUM_MAX_EDT_OCEAN = (/0.60, 0.00, 0.20/) CUM_FADJ_MASSFLX = (/1.00, 1.00, 1.00/) CUM_AVE_LAYER = (/50., 75., 25./) CUM_T_STAR = (/15., -99., -99./) CUM_USE_EXCESS = (/1, 1, 1/) MOIST_TRIGGER = 0 FRAC_MODIS = 1 ADV_TRIGGER = 0 DCAPE_THRESHOLD = 70. LCL_TRIGGER = 0 TAU_OCEA_CP = 7200. TAU_LAND_CP = 7200. MX_BUOY1 = (real(c_cp)*5.0 + real(c_xlv)*2.e-3)*0.025 MX_BUOY2 = (real(c_cp)*10.+real(c_xlv)*4.e-3) USE_CLOUD_DISSIPATION = 0. USE_GUSTINESS = 0 USE_RANDOM_NUM = 0. BETA_SH = 2.2 USE_LINEAR_SUBCL_MF = 1 CAP_MAXS = 50. LIQ_ICE_NUMBER_CONC = 1 ALPHA_ADV_TUNING = 0.8 SIG_FACTOR = 0.22 != exponential factor for the sigma determination (orig = 0.1) hei_down_land = 0. hei_down_ocean = 0. hei_updf_land = 0. hei_updf_ocean = 0. max_edt_land = 0. max_edt_ocean = 0. fadj_massflux = 0. temp_star = 0. ave_layer = 0. c0 = 0. col_sat_adv_threshold = 0.94 chem_adj_autoc = 0. time_in = 0. int_time = 0. ispc_co = 0 whoami_all = 0 jcol = 0 itime1_in = 0 nrec = 0 ntimes = 0 use_excess = 0 output_sound = 0 ind_chem = 0 chem_name_mask = 0 chem_name_mask_evap = 0 use_c1d = .false. first_guess_w = .false. wrtgrads = .false. chem_name = "" if(allocated(hcts)) then hcts%hstar = 0. hcts%dhr = 0. hcts%ak0 = 0. hcts%dak = 0. endif ! Informa que já inicializado modConvParGF_initialized = .true. ! Retorna 0, foi inicializado dessa vez is_init = 0 end function initModConvParGF !----------------------------------------------------------------------- subroutine modConvParGFDriver(mxp, myp, mzp, mtp, nmp, time, itime1 & , ims, ime, jms, jme, kms, kme & , its, ite, jts, jte, kts, kte & , flip & , fscav & , mynum & , dt & , dx2d & , stochastic_sig & , zm & , zt & , dm & , lons & , lats & , aot500 & , temp2m & , sflux_r & , sflux_t & , qexcp & , hexcp & , wlpool & , topt & , xland & , sfc_press & , kpbl & , tke_pbl & , col_sat & , u_wind & , v_wind & , w_wind & , temp & , press & , rvap & , mp_ice & , mp_liq & , mp_cf & , curr_rvap & , tracer &!-note: uses GEOS-5 data structure !---- forcings--- , buoy_exc & , rthften &! gsf_t , rqvften &! gsf_q , rth_advten &!advf_t , rthblten &!sgsf_t , rqvblten &!sgsf_q !---- output ---- , conprr & , lightn_dens & , rh_dicycle_fct & , rthcuten & , rqvcuten & , rqccuten & , rnlcuten & , rnicuten & , rucuten & , rvcuten & , sub_mpqi & , sub_mpql & , sub_mpcf & , rbuoycuten & , rchemcuten & , revsu_gf & , prfil_gf & ! , do_this_column & , ierr4d & , jmin4d & , klcl4d & , k224d & , kbcon4d & , ktop4d & , kstabi4d & , kstabm4d & , cprr4d & , xmb4d & , edt4d & , pwav4d & , sigma4d & , pcup5d & , up_massentr5d & , up_massdetr5d & , dd_massentr5d & , dd_massdetr5d & , zup5d & , zdn5d & , prup5d & , prdn5d & , clwup5d & , tup5d & , conv_cld_fr5d & !-- for debug/diagnostic , aa0, aa1, aa1_adv, a1_radpbl, aa1_bl, aa2, aa3, aa1_cin, tau_bl, tau_ec & , var2d, var3d_agf, var3d_bgf, var3d_cgf, var3d_dgf) !! Driver !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! Driver !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'modConvParGFDriver' ! Nome da subrotina !Variables (input, output, inout) !------------------------------------------------------------------------ integer, intent(in) :: ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte, mzp, mxp, myp, mtp, nmp, mynum & , itime1 integer, intent(in) :: flip(mzp) integer, intent(in) :: kpbl(its:ite, jts:jte) real, intent(in) :: dt real, intent(in) :: time real, intent(in) :: zm(kts:kte, its:ite, jts:jte) real, intent(in) :: zt(kts:kte, its:ite, jts:jte) real, intent(in) :: u_wind(kts:kte, its:ite, jts:jte) real, intent(in) :: v_wind(kts:kte, its:ite, jts:jte) real, intent(in) :: w_wind(kts:kte, its:ite, jts:jte) real, intent(in) :: rvap(kts:kte, its:ite, jts:jte) real, intent(in) :: temp(kts:kte, its:ite, jts:jte) real, intent(in) :: press(kts:kte, its:ite, jts:jte) real, intent(in) :: dm(kts:kte, its:ite, jts:jte) real, intent(in) :: curr_rvap(kts:kte, its:ite, jts:jte) real, intent(in) :: buoy_exc(kts:kte, its:ite, jts:jte) real, intent(in) :: qexcp(kts:kte, its:ite, jts:jte) real, intent(in) :: hexcp(kts:kte, its:ite, jts:jte) real, intent(in) :: rthften(kts:kte, its:ite, jts:jte) real, intent(in) :: rqvften(kts:kte, its:ite, jts:jte) real, intent(in) :: rth_advten(kts:kte, its:ite, jts:jte) real, intent(in) :: rthblten(kts:kte, its:ite, jts:jte) real, intent(in) :: rqvblten(kts:kte, its:ite, jts:jte) real, intent(in) :: mp_ice(nmp, kts:kte, its:ite, jts:jte) real, intent(in) :: mp_liq(nmp, kts:kte, its:ite, jts:jte) real, intent(in) :: mp_cf(nmp, kts:kte, its:ite, jts:jte) real, intent(in) :: tracer(its:ite, jts:jte, kts:kte, mtp) !! tracer has different data structure (i,j,k,ispc) ********* real, intent(in) :: topt(its:ite, jts:jte) real, intent(in) :: aot500(its:ite, jts:jte) real, intent(in) :: temp2m(its:ite, jts:jte) real, intent(in) :: sfc_press(its:ite, jts:jte) real, intent(in) :: sflux_r(its:ite, jts:jte) real, intent(in) :: sflux_t(its:ite, jts:jte) real, intent(in) :: xland(its:ite, jts:jte) real, intent(in) :: lons(its:ite, jts:jte) real, intent(in) :: lats(its:ite, jts:jte) real, intent(in) :: stochastic_sig(its:ite, jts:jte) real, intent(in) :: tke_pbl(its:ite, jts:jte) real, intent(in) :: col_sat(its:ite, jts:jte) integer, intent(inout) :: do_this_column(its:ite, jts:jte) !- for convective transport and cloud/radiation (OUT) integer, intent(inout) :: ierr4d(mxp, myp, p_maxiens) integer, intent(inout) :: jmin4d(mxp, myp, p_maxiens) integer, intent(inout) :: klcl4d(mxp, myp, p_maxiens) integer, intent(inout) :: k224d(mxp, myp, p_maxiens) integer, intent(inout) :: kbcon4d(mxp, myp, p_maxiens) integer, intent(inout) :: ktop4d(mxp, myp, p_maxiens) integer, intent(inout) :: kstabi4d(mxp, myp, p_maxiens) integer, intent(inout) :: kstabm4d(mxp, myp, p_maxiens) real, intent(inout) :: fscav(mtp) real, intent(inout) :: rh_dicycle_fct(its:ite, jts:jte) !input but communicate to another subroutine real, intent(inout) :: dx2d(its:ite, jts:jte) real, intent(inout) :: wlpool(its:ite, jts:jte) real, intent(inout) :: pcup5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: up_massentr5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: up_massdetr5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: dd_massentr5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: dd_massdetr5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: zup5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: zdn5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: prup5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: prdn5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: clwup5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: tup5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: conv_cld_fr5d(mxp, myp, mzp, p_maxiens) real, intent(inout) :: cprr4d(mxp, myp, p_maxiens) real, intent(inout) :: xmb4d(mxp, myp, p_maxiens) real, intent(inout) :: edt4d(mxp, myp, p_maxiens) real, intent(inout) :: pwav4d(mxp, myp, p_maxiens) real, intent(inout) :: sigma4d(mxp, myp, p_maxiens) !--for debug real, intent(inout) :: aa0(mxp, myp) real, intent(inout) :: aa1(mxp, myp) real, intent(inout) :: aa1_adv(mxp, myp) real, intent(inout) :: a1_radpbl(mxp, myp) real, intent(inout) :: aa2(mxp, myp) real, intent(inout) :: aa3(mxp, myp) real, intent(inout) :: aa1_bl(mxp, myp) real, intent(inout) :: aa1_cin(mxp, myp) real, intent(inout) :: tau_bl(mxp, myp) real, intent(inout) :: tau_ec(mxp, myp) real, intent(inout) :: var2d(mxp, myp) real, intent(out) :: conprr(its:ite, jts:jte) real, intent(out) :: lightn_dens(its:ite, jts:jte) real, intent(out) :: rthcuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rqvcuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rqccuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rnlcuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rnicuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rucuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rvcuten(kts:kte, its:ite, jts:jte) real, intent(out) :: rbuoycuten(kts:kte, its:ite, jts:jte) real, intent(out) :: revsu_gf(kts:kte, its:ite, jts:jte) real, intent(out) :: prfil_gf(kts:kte, its:ite, jts:jte) real, intent(out) :: var3d_agf(kts:kte, its:ite, jts:jte) real, intent(out) :: var3d_bgf(kts:kte, its:ite, jts:jte) real, intent(out) :: var3d_cgf(kts:kte, its:ite, jts:jte) real, intent(out) :: var3d_dgf(kts:kte, its:ite, jts:jte) real, intent(out) :: sub_mpqi(nmp, kts:kte, its:ite, jts:jte) real, intent(out) :: sub_mpql(nmp, kts:kte, its:ite, jts:jte) real, intent(out) :: sub_mpcf(nmp, kts:kte, its:ite, jts:jte) real, intent(out) :: rchemcuten(mtp, kts:kte, its:ite, jts:jte) !! rchemcuten uses the GF data structure (ispc,k,i,j) ********* !---------------------------------------------------------------------- ! local variabels ! basic environmental input includes ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off ! convection for this call only and at that particular gridpoint ! real, dimension(kts:kte, its:ite, jts:jte) :: tpert_h, tpert_v real, dimension(its:ite, jts:jte) :: rtgt real, dimension(its:ite, kts:kte) :: & zo, temp_old, qv_old, PO, US, VS, rhoi, phil & , temp_new_dp, qv_new_dp, temp_new_sh, qv_new_sh, z2d & , tkeg, rcpg, dhdt, temp_new_md, qv_new_md & , temp_new_bl, qv_new_bl, dm2d, temp_tendqv, qv_curr & , buoy_exc2d, revsu_gf_2d, prfil_gf_2d, var3d_Agf_2d & , var3d_Bgf_2d, temp_new, qv_new, Tpert_2d & , temp_new_adv, qv_new_adv real, dimension(its:ite, kts:kte, p_maxiens) :: & outt, outq, outqc, outu, outv, outbuoy, outnliq, outnice real, dimension(mtp, its:ite, kts:kte) :: se_chem real, dimension(mtp, its:ite, kts:kte, p_maxiens) :: out_chem real, dimension(nmp, its:ite, kts:kte) :: mpqi, mpql, mpcf real, dimension(nmp, its:ite, kts:kte, p_maxiens) :: outmpqi, outmpql, outmpcf real, dimension(its:ite) :: ter11, xlandi, pbl, zws, ccn, psur & , ztexec, zqexec, h_sfc_flux, le_sfc_flux, tsur & , xlons, xlats, fixout_qv, cum_ztexec, cum_zqexec real, dimension(its:ite, kts:kte, 1:p_ens4) :: omeg real, dimension(kts:kte) :: min_tend, distance integer, dimension(its:ite) :: kpbli, last_ierr integer :: i, j, k, kr, n, itf, jtf, ktf, ispc, zmax, status real :: dp, dq, exner, dtdt, pten, pqen, paph, zrho, pahfs, pqhfl, zkhvfl, pgeoh real :: fixouts, dt_inv real, dimension(mxp, myp, -1:5) :: dummy_precip integer :: imemory, irun, jlx, kk, kss, plume, ii_plume !---------------------------------------------------------------------- !-do not change this itf = ite ktf = kte - 1 jtf = jte int_time = int_time + dt whoami_all = mynum time_in = time itime1_in = itime1 !---------------------------------------------------------------------- if (abs(C1) > 0.) use_c1d = .true. !-- big loop over j dimension do j = jts, jtf jcol = J !-- initialization do i = its, itf rtgt(i, j) = 1.0 end do do i = its, itf ztexec(i) = 0.0 zqexec(i) = 0.0 last_ierr(i) = -999 fixout_qv(i) = 1.0 ! conprr(i, j) = 0.0 lightn_dens(i, j) = 0.0 var2d(i, j) = 0.0 !--- (i,k) revsu_gf_2d(i, :) = 0.0 prfil_gf_2d(i, :) = 0.0 var3d_agf_2d(i, :) = 0.0 var3d_bgf_2d(i, :) = 0.0 Tpert_2d(i, :) = 0.0 ! temp_tendqv(i, :) = 0.0 !- tendencies (w/ maxiens) outt(i, :, :) = 0.0 outu(i, :, :) = 0.0 outv(i, :, :) = 0.0 outq(i, :, :) = 0.0 outqc(i, :, :) = 0.0 outnice(i, :, :) = 0.0 outnliq(i, :, :) = 0.0 outbuoy(i, :, :) = 0.0 end do if (APPLY_SUB_MP == 1) then do i = its, itf !- tendencies (w/ nmp and maxiens) outmpqi(:, i, :, :) = 0.0 outmpql(:, i, :, :) = 0.0 outmpcf(:, i, :, :) = 0.0 end do end if do i = its, itf omeg(i, :, :) = 0.0 end do if (USE_TRACER_TRANSP == 1) then out_chem = 0.0 end if ! if (AUTOCONV == 2) then do i = its, itf ccn(i) = max(100., (370.37*(0.01 + max(0., aot500(i, j))))**1.555) end do else do i = its, itf ccn(i) = 100. end do end if do i = its, itf xlandi(i) = xland(i, j)!flag < 1 para land !flag =1 para water psur(i) = sfc_press(i, j)*1.e-2 ! mbar tsur(i) = temp2m(i, j) ter11(i) = max(0., topt(i, j)) kpbli(i) = kpbl(i, j) xlons(i) = lons(i, j)*180./3.14159 xlats(i) = lats(i, j)*180./3.14159 end do do k = kts, ktf do i = its, itf kr = k !+1 !<<<< only kr=k (the input was already converted to the BRAMS vertical grid, ! see cup_grell3.f90 routine) !- heigths, current pressure, temp and water vapor mix ratio zo(i, k) = zt(kr, i, j)*rtgt(i, j) + topt(i, j) po(i, k) = press(kr, i, j)*1.e-2 !mbar temp_old(i, k) = temp(kr, i, j) qv_old(i, k) = rvap(kr, i, j) ! @ begin of the timestep qv_curr(i, k) = curr_rvap(kr, i, j) ! current (after dynamics + physical processes called before GF) !- air density, TKE and cloud liq water mixing ratio rhoi(i, k) = 1.e2*po(i, k)/(287.04*temp_old(i, k)*(1.+0.608*qv_old(i, k))) tkeg(i, k) = c_tkmin rcpg(i, k) = 0. !- wind velocities us(i, k) = u_wind(kr, i, j) vs(i, k) = v_wind(kr, i, j) omeg(i, k, :) = w_wind(kr, i, j) dm2d(i, k) = dm(kr, i, j) !omeg (i,k,:)= -g*rho(kr,i,j)*w(kr,i,j) !-buoyancy excess buoy_exc2d(i, k) = buoy_exc(kr, i, j) !- temp/water vapor modified only by advection temp_new_adv(i, k) = temp_old(i, k) + (rth_advten(kr, i, j))*dt qv_new_adv(i, k) = qv_old(i, k) + (rqvften(kr, i, j))*dt end do end do if (APPLY_SUB_MP == 1) then do k = kts, ktf do i = its, itf kr = k !+1 !<<<< only kr=k !- microphysics ice and liq mixing ratio, and cloud fraction of the host model !- (only subsidence is applied) mpqi(:, i, k) = mp_ice(:, kr, i, j) ! kg/kg mpql(:, i, k) = mp_liq(:, kr, i, j) ! kg/kg mpcf(:, i, k) = mp_cf(:, kr, i, j) ! 1 end do end do end if if (USE_TRACER_TRANSP == 1) then do k = kts, kte do i = its, itf kr = k !+1 !- atmos composition do ispc = 1, mtp se_chem(ispc, i, k) = max(p_mintracer, tracer(i, j, flip(kr), ispc)) end do end do end do end if !- pbl (i) = depth of pbl layer (m) !- kpbli(i) = index of zo(i,k) !call get_zi_gf(j,its,ite,kts,kte,its,itf,ktf,ierrs,kpbli,pbl,& ! tkeg,rcpg,zo,ter11,tkmin) do i = its, itf pbl(i) = zo(i, kpbli(i)) - topt(i, j) !print*,"PBL=",kpbli(i),zo(i,kpbli(i)),topt(i,j),pbl (i) end do !- begin: for GATE soundings------------------------------------------- !- this section is intended for model developments only and must !- not be used for normal runs. if (p_use_gate) then if (CLEV_GRID == 0) stop "use_gate requires CLEV_GRID 1 or 2" if (USE_TRACER_TRANSP == 1) then ispc_co = 1 if (.not. allocated(hcts)) allocate (hcts(mtp)) chem_name_mask(:) = 1 !--- dummy initization FSCAV do i = 1, mtp !FSCAV(i) = 0.1 !km^-1 fscav(i) = 1.e-5 !km^-1 hcts(i)%hstar = 0.0 !8.300e+4! 2.4E+3 !59. hcts(i)%dhr = 0.0 !7400. !5000. !4200. hcts(i)%ak0 = 0.0 hcts(i)%dak = 0.0 ! H2O2 0.00000 8.300e+4 7400.00000 0.00000 0.00000 ! HNO3 0.00000 2.100e+5 8700.00000 0.00000 0.00000 ! NH3 0.00000 59.00000 4200.00000 0.00000 0.00000 ! SO2 0.00000 2.400e+3 5000.00000 0.00000 0.00000 end do do i = its, itf se_chem(1:mtp, i, kts:kpbli(i) - 1) = 1.+1.e-6 do k = kpbli(i), kte se_chem(1:mtp, i, k) = 1.*exp(-(max(0., 0.9*float(k - kpbli(i)))/float(kpbli(i)))) + 1.e-6 end do do k = kts + 1, kte - 1 se_chem(1:mtp, i, k) = 1./3.*(se_chem(1:mtp, i, k) + se_chem(1:mtp, i, k - 1) + se_chem(1:mtp, i, k + 1)) end do end do end if !--- only for GATE soundingg if (trim(rundata) == "GATE.dat") then jlx = jl !jlx= 1 ! to run with only one soundings !jlx= 42 ! to run with only one soundings do i = its, itf do k = kts, kte po(i, k) = 0.5*(ppres(jlx, k) + ppres(jlx, min(kte, k + 1))) temp_old(i, k) = ptemp(jlx, k) + 273.15 qv_old(i, k) = pq(jlx, k)/1000. us(i, k) = pu(jlx, k) vs(i, k) = pv(jlx, k) omeg(i, k, :) = pvervel(jlx, k) phil(i, k) = pgeo(jlx, k)*c_grav !geo rhoi(i, k) = 1.e2*po(i, k)/(c_rgas*temp_old(i, k)) end do do k = kts, kte mpql(:, i, k) = 0. mpql(:, i, k) = 0. mpcf(:, i, k) = 0. if (po(i, k) > 900. .or. po(i, k) < 300.) cycle pqen = exp((-3.e-5*(po(i, k) - 550.)**2)) pten = min(1., (max(0., (temp_old(i, k) - c_t_ice))/(c_t_0 - c_t_ice))**2) mpql(:, i, k) = 3.*pqen*pten mpqi(:, i, k) = 3.*pqen*(1.-pten) mpcf(:, i, k) = (mpqi(:, i, k) + mpql(:, i, k))*100. end do do k = kts, kte zo(i, k) = 0.5*(phil(i, k) + phil(i, min(kte, k + 1)))/c_grav !meters end do ter11(i) = phil(i, 1)/c_grav ! phil is given in g*h. psur(i) = ppres(jlx, 1) tsur(i) = temp2m(i, j) !temp_old(i,1) kpbli(i) = 5 pbl(i) = zo(i, kpbli(i)) zws(i) = 1.0 ! wstar do k = kts, ktf temp_new(i, k) = temp_old(i, k) + dt*(zadvt(jlx, k) + zqr(jlx, k))/86400. qv_new(i, k) = qv_old(i, k) + dt*zadvq(jlx, k) temp_new_dp(i, k) = temp_old(i, k) + dt*(zadvt(jlx, k) + zqr(jlx, k))/86400. qv_new_dp(i, k) = qv_old(i, k) + dt*zadvq(jlx, k) temp_new_md(i, k) = temp_new_dp(i, k) qv_new_md(i, k) = qv_new_dp(i, k) temp_new_bl(i, k) = temp_new_dp(i, k) qv_new_bl(i, k) = qv_new_dp(i, k) temp_new_adv(i, k) = temp_old(i, k) + dt*zadvt(jlx, k)/86400. qv_new_adv(i, k) = qv_old(i, k) + dt*zadvq(jlx, k) end do end do end if end if !- end: for GATE soundings------------------------------------------- ! !- get execess T and Q for source air parcels do i = its, itf pten = temp_old(i, 1) pqen = qv_old(i, 1) paph = 100.*psur(i) zrho = paph/(287.04*(temp_old(i, 1)*(1.+0.608*qv_old(i, 1)))) !- sensible and latent sfc fluxes for the heat-engine closure h_sfc_flux(i) = zrho*real(c_cp)*sflux_t(i, j)!W/m^2 le_sfc_flux(i) = zrho*real(c_xlv)*sflux_r(i, j)!W/m^2 ! !- local le and h fluxes for W* pahfs = -sflux_t(i, j)*zrho*1004.64 !W/m^2 pqhfl = -sflux_r(i, j) !kg/m^2/s !- buoyancy flux (h+le) zkhvfl = (pahfs/1004.64 + 0.608*pten*pqhfl)/zrho ! K m s-1 !- depth of 1st model layer !- (zo(1)-top is ~ 1/2 of the depth of 1st model layer, => mult by 2) pgeoh = 2.*(zo(i, 1) - topt(i, j))*c_grav ! m+2 s-2 !-convective-scale velocity w* !- in the future, change 0.001 by ustar^3 zws(i) = max(0., 0.001 - 1.5*0.41*zkhvfl*pgeoh/pten) ! m+3 s-3 if (zws(i) > tiny(pgeoh)) then !-convective-scale velocity w* zws(i) = 1.2*zws(i)**.3333 !- temperature excess ztexec(i) = max(0., -1.5*pahfs/(zrho*zws(i)*1004.64)) ! K !print*,"exce1=",pahfs,zrho,ztexec(i),zws(i),pgeoh,zo(i,1),topt(i,j) !call flush(6) !- moisture excess zqexec(i) = max(0., -1.5*pqhfl/(zrho*zws(i))) !kg kg-1 end if ! zws > 0 !if(ztexec(i) > 1.) print*,"T",ztexec(i),h_sfc_flux(i) !if(zqexec(i)*1000 > 0.5) then ! print*,"Q",1000*zqexec(i),le_sfc_flux(i),(ztexec(i)*cp+xlv*zqexec(i))/1000. !endif ! !- zws for shallow convection closure (Grant 2001) !- depth of the pbl pgeoh = pbl(i)*c_grav !-convective-scale velocity W* (m/s) zws(i) = max(0., 0.001 - 1.5*0.41*zkhvfl*pgeoh/pten) zws(i) = 1.2*zws(i)**.3333 end do ! !------ CALL CUMULUS PARAMETERIZATION ! do ii_plume = 1, p_maxiens if (ii_plume == 1) then plume = p_shal c0 = C0_SHAL end if if (ii_plume == 2) then plume = p_deep c0 = C0_DEEP end if if (ii_plume == 3) then plume = p_mid c0 = C0_MID end if if (ICUMULUS_GF(plume) /= p_on) cycle hei_down_land = CUM_HEI_DOWN_LAND(plume) hei_down_ocean = CUM_HEI_DOWN_OCEAN(plume) hei_updf_land = CUM_HEI_UPDF_LAND(plume) hei_updf_ocean = CUM_HEI_UPDF_OCEAN(plume) max_edt_land = CUM_MAX_EDT_LAND(plume) max_edt_ocean = CUM_MAX_EDT_OCEAN(plume) fadj_massflux = CUM_FADJ_MASSFLX(plume) use_excess = CUM_USE_EXCESS(plume) ave_layer = CUM_AVE_LAYER(plume) temp_star = CUM_T_STAR(plume) !print*,"plume=",plume,shal,mid,deep !-- set minimum/max for excess of T and Q if (use_excess == 0) then cum_ztexec(:) = 0. cum_zqexec(:) = 0. elseif (use_excess == 1) then cum_ztexec(:) = ztexec(:) cum_zqexec(:) = zqexec(:) elseif (use_excess == 2) then do i = its, itf cum_zqexec(i) = min(5.e-4, max(1.e-4, zqexec(i)))! kg kg^-1 cum_ztexec(i) = min(0.5, max(0.2, ztexec(i)))! Kelvin end do else do i = its, itf if (xlandi(i) > 0.98) then ! ocean cum_zqexec(i) = min(8.e-4, max(5.e-4, zqexec(i)))! kg kg^-1 cum_ztexec(i) = min(1., max(0.5, ztexec(i)))! Kelvin else ! land cum_ztexec(i) = ztexec(i) cum_zqexec(i) = zqexec(i) end if end do end if ! !--- replace 'q' and 't' excess in case of use of the cold pool scheme ! if (CONVECTION_TRACER == 1 .and. plume == p_deep) then if (USE_GUSTINESS == 1) then k = 2 ! surface in brams do i = its, itf cum_ztexec(i) = (hexcp(k, i, j) - qexcp(k, i, j)*real(c_xlv))/real(c_cp) cum_zqexec(i) = qexcp(k, i, j) end do else cum_ztexec(:) = 0. cum_zqexec(:) = 0. end if end if ! ! !-- shallow convection ! if (plume == p_shal) then do i = its, itf do k = kts, ktf kr = k!+1 <<<< if (p_use_gate) then dhdt(i, k) = real(c_cp)*(temp_new_dp(i, k) - temp_old(i, k)) + real(c_xlv)*(qv_new_dp(i, k) - qv_old(i, k)) temp_new(i, k) = temp_new_dp(i, k) qv_new(i, k) = qv_new_dp(i, k) else temp_new(i, k) = temp_old(i, k) + (rthblten(kr, i, j) + rthften(kr, i, j))*dt qv_new(i, k) = qv_old(i, k) + (rqvblten(kr, i, j) + rqvften(kr, i, j))*dt qv_new(i, k) = max(p_smallerqv, qv_new(i, k)) !- only pbl forcing changes moist static energy dhdt(i, k) = real(c_cp)*(rthblten(kr, i, j)) + real(c_xlv)*(rqvblten(kr, i, j)) !- all forcings change moist static energy dhdt(i, k) = dhdt(i, k) + real(c_cp)*rthften(kr, i, j) + real(c_xlv)*rqvften(kr, i, j) end if end do end do end if ! !--- deep convection if (plume == p_deep) then if (p_use_gate) then do k = kts, ktf do i = its, itf temp_new(i, k) = temp_new_dp(i, k) qv_new(i, k) = qv_new_dp(i, k) end do end do else do k = kts, ktf do i = its, itf kr = k!+1 <<<< temp_new(i, k) = temp_old(i, k) + (rthblten(kr, i, j) + rthften(kr, i, j))*dt qv_new(i, k) = qv_old(i, k) + (rqvblten(kr, i, j) + rqvften(kr, i, j))*dt temp_new_bl(i, k) = temp_old(i, k) + (rthblten(kr, i, j))*dt qv_new_bl(i, k) = qv_old(i, k) + (rqvblten(kr, i, j))*dt end do end do end if end if ! !--- mid/congestus type convection if (plume == p_mid) then if (p_use_gate) then do k = kts, ktf do i = its, itf temp_new(i, k) = temp_new_dp(i, k) qv_new(i, k) = qv_new_dp(i, k) end do end do else do i = its, itf do k = kts, ktf kr = k!+1 <<<< temp_new(i, k) = temp_old(i, k) + (rthblten(kr, i, j) + rthften(kr, i, j))*dt qv_new(i, k) = qv_old(i, k) + (rqvblten(kr, i, j) + rqvften(kr, i, j))*dt qv_new(i, k) = max(p_smallerqv, qv_new(i, k)) !- only pbl forcing changes moist static energy dhdt(i, k) = real(c_cp)*(rthblten(kr, i, j)) + real(c_xlv)*(rqvblten(kr, i, j)) !- all forcings change moist static energy dhdt(i, k) = dhdt(i, k) + real(c_cp)*rthften(kr, i, j) + real(c_xlv)*rqvften(kr, i, j) !- temp/water vapor modified only by bl processes temp_new_bl(i, k) = temp_old(i, k) + (rthblten(kr, i, j))*dt qv_new_bl(i, k) = qv_old(i, k) + (rqvblten(kr, i, j))*dt end do end do end if end if ! call cupGf(its, ite, kts, kte, itf, ktf, mtp, nmp, fscav & , p_cumulus_type(plume) & , CLOSURE_CHOICE(plume) & , CUM_ENTR_RATE(plume) & , CUM_USE_EXCESS(plume) & !- input data , dx2d(:, j) & , stochastic_sig(:, j) & , col_sat(:, j) & , tke_pbl(:, j) & , rh_dicycle_fct(:, j) & , wlpool(:, j) & , dt & , kpbli & , cum_ztexec & , cum_zqexec & , ccn & , rhoi & , omeg & , temp_old & , qv_old & , ter11 & , h_sfc_flux & , le_sfc_flux & , xlons & , xlats & , xlandi & , temp_new & , qv_new & , temp_new_bl & , qv_new_bl & , temp_new_adv & , qv_new_adv & , zo & , po & , tsur & , psur & , us & , vs & , dm2d & , se_chem & , zws & , dhdt & , buoy_exc2d & , mpqi & , mpql & , mpcf & , last_ierr(:) & !output data , outt(:, :, plume) & , outq(:, :, plume) & , outqc(:, :, plume) & , outu(:, :, plume) & , outv(:, :, plume) & , outnliq(:, :, plume) & , outnice(:, :, plume) & , outbuoy(:, :, plume) & , outmpqi(:, :, :, plume) & , outmpql(:, :, :, plume) & , outmpcf(:, :, :, plume) & , out_chem(:, :, :, plume) & !- for convective transport , ierr4d(:, j, plume) & , jmin4d(:, j, plume) & , klcl4d(:, j, plume) & , k224d(:, j, plume) & , kbcon4d(:, j, plume) & , ktop4d(:, j, plume) & , kstabi4d(:, j, plume) & , kstabm4d(:, j, plume) & , cprr4d(:, j, plume) & , xmb4d(:, j, plume) & , edt4d(:, j, plume) & , pwav4d(:, j, plume) & , sigma4d(:, j, plume) & , pcup5d(:, j, :, plume) & , up_massentr5d(:, j, :, plume) & , up_massdetr5d(:, j, :, plume) & , dd_massentr5d(:, j, :, plume) & , dd_massdetr5d(:, j, :, plume) & , zup5d(:, j, :, plume) & , zdn5d(:, j, :, plume) & , prup5d(:, j, :, plume) & , prdn5d(:, j, :, plume) & , clwup5d(:, j, :, plume) & , tup5d(:, j, :, plume) & , conv_cld_fr5d(:, j, :, plume) & !-- for debug/diag , aa0(:, j), aa1(:, j), aa1_adv(:, j), a1_radpbl(:, j), aa2(:, j), aa3(:, j) & , aa1_bl(:, j), aa1_cin(:, j), tau_bl(:, j), tau_ec(:, j) & !-- for diag , lightn_dens(:, j) & , var2d(:, j) & , revsu_gf_2d & , prfil_gf_2d & , var3d_agf_2d & , var3d_bgf_2d & , Tpert_2d & ) end do !- plume !--- reset ierr4d to value different of zero in case the correspondent !--- plume (shalllow, congestus, deep) was not actually used do n = 1, p_maxiens if (ICUMULUS_GF(n) == p_off) ierr4d(:, j, n) = -99 end do do i = its, itf do_this_column(i, j) = 0 loop1: do n = 1, p_maxiens if (ierr4d(i, j, n) == 0) then do_this_column(i, j) = 1 exit loop1 end if end do loop1 end do !----------- check for negative water vapor mix ratio do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, ktf temp_tendqv(i, k) = outq(i, k, p_shal) + outq(i, k, p_deep) + outq(i, k, p_mid) end do do k = kts, ktf distance(k) = qv_curr(i, k) + temp_tendqv(i, k)*dt end do if (minval(distance(kts:ktf)) < 0.) then zmax = minloc(distance(kts:ktf), 1) if (abs(temp_tendqv(i, zmax)*dt) < p_mintracer) then fixout_qv(i) = 0.999999 !fixout_qv(i)= 0. else fixout_qv(i) = ((p_smallerqv - qv_curr(i, zmax)))/(temp_tendqv(i, zmax)*dt) end if fixout_qv(i) = max(0., min(fixout_qv(i), 1.)) end if end do !------------ feedback !-- deep convection do i = its, itf if (do_this_column(i, j) == 0) cycle cprr4d(i, j, p_deep) = cprr4d(i, j, p_deep)*fixout_qv(i) cprr4d(i, j, p_mid) = cprr4d(i, j, p_mid)*fixout_qv(i) cprr4d(i, j, p_shal) = cprr4d(i, j, p_shal)*fixout_qv(i) conprr(i, j) = (cprr4d(i, j, p_deep) + cprr4d(i, j, p_mid) + cprr4d(i, j, p_shal)) conprr(i, j) = max(0., conprr(i, j)) end do !-- deep + shallow + mid convection do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 !- feedback the tendencies from convection rthcuten(kr, i, j) = (outt(i, k, p_shal) + outt(i, k, p_deep) + outt(i, k, p_mid))*fixout_qv(i) rqvcuten(kr, i, j) = (outq(i, k, p_shal) + outq(i, k, p_deep) + outq(i, k, p_mid))*fixout_qv(i) rqccuten(kr, i, j) = (outqc(i, k, p_shal) + outqc(i, k, p_deep) + outqc(i, k, p_mid))*fixout_qv(i) revsu_gf(kr, i, j) = revsu_gf_2d(i, k)*fixout_qv(i) !-- already contains deep and mid amounts. !---these arrays are only for the deep plume mode prfil_gf(kr, i, j) = prfil_gf_2d(i, k)*fixout_qv(i) !-- ice/liq prec flux of the deep plume !VAR3d_aGF(kr,i,j)= var3d_gf_2d(i,k) !-- vertical velocity of the deep plume var3d_agf(kr, i, j) = outt(i, k, p_mid)*fixout_qv(i) !-- var3d_bgf(kr, i, j) = outq(i, k, p_mid)*fixout_qv(i) !-- if (ICUMULUS_GF(p_shal) == p_off) then var3d_cgf(kr, i, j) = outqc(i, k, p_deep)*fixout_qv(i) !-- var3d_dgf(kr, i, j) = outqc(i, k, p_mid)*fixout_qv(i) !-- else var3d_cgf(kr, i, j) = outt(i, k, p_shal)*fixout_qv(i) !-- var3d_dgf(kr, i, j) = outq(i, k, p_shal)*fixout_qv(i) !-- end if end do end do if (USE_MOMENTUM_TRANSP > 0) then do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 rucuten(kr, i, j) = (outu(i, k, p_deep) + outu(i, k, p_mid) + outu(i, k, p_shal))*fixout_qv(i) rvcuten(kr, i, j) = (outv(i, k, p_deep) + outv(i, k, p_mid) + outv(i, k, p_shal))*fixout_qv(i) end do end do end if if (APPLY_SUB_MP == 1) then do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 sub_mpql(:, kr, i, j) = (outmpql(:, i, k, p_deep) + outmpql(:, i, k, p_mid) + outmpql(:, i, k, p_shal)) & * fixout_qv(i) sub_mpqi(:, kr, i, j) = (outmpqi(:, i, k, p_deep) + outmpqi(:, i, k, p_mid) + outmpqi(:, i, k, p_shal)) & * fixout_qv(i) sub_mpcf(:, kr, i, j) = (outmpcf(:, i, k, p_deep) + outmpcf(:, i, k, p_mid) + outmpcf(:, i, k, p_shal)) & * fixout_qv(i) end do end do end if if (LIQ_ICE_NUMBER_CONC == 1) then do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 rnicuten(kr, i, j) = (outnice(i, k, p_shal) + outnice(i, k, p_deep) + outnice(i, k, p_mid))*fixout_qv(i) rnlcuten(kr, i, j) = (outnliq(i, k, p_shal) + outnliq(i, k, p_deep) + outnliq(i, k, p_mid))*fixout_qv(i) end do end do end if if (USE_TRACER_TRANSP == 1) then do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 rchemcuten(:, kr, i, j) = (out_chem(:, i, k, p_deep) + out_chem(:, i, k, p_mid) + out_chem(:, i, k, p_shal)) & * fixout_qv(i) end do end do !- constrain positivity for tracers do i = its, itf if (do_this_column(i, j) == 0) cycle do ispc = 1, mtp if (chem_name_mask(ispc) == 0) cycle do k = kts, ktf distance(k) = se_chem(ispc, i, k) + rchemcuten(ispc, k, i, j)*dt end do !-- fixer for mass of tracer if (minval(distance(kts:ktf)) < 0.) then zmax = minloc(distance(kts:ktf), 1) if (abs(rchemcuten(ispc, zmax, i, j)*dt) < p_mintracer) then fixouts = 0.999999 !fixouts= 0. else fixouts = ((p_mintracer - se_chem(ispc, i, zmax)))/(rchemcuten(ispc, zmax, i, j)*dt) end if if (fixouts > 1. .or. fixouts < 0.) fixouts = 0. rchemcuten(ispc, kts:ktf, i, j) = fixouts*rchemcuten(ispc, kts:ktf, i, j) end if end do end do end if if (CONVECTION_TRACER == 1) then do i = its, itf if (do_this_column(i, j) == 0) cycle do k = kts, kte kr = k!+1 rbuoycuten(kr, i, j) = (outbuoy(i, k, p_deep) + outbuoy(i, k, p_mid) + outbuoy(i, k, p_shal))*fixout_qv(i) !print*,"RBUOYCUTEN", RBUOYCUTEN (kr,i,j),outbuoy(i,k,deep),& ! outbuoy(i,k,mid),outbuoy(i,k,shal) end do end do !----- for output only !if(use_gustiness==1 .or. use_gustiness ==2 ) then !print*,"H-T",cp*1.1*maxval(sflux_t(:,j))& ! ,xlv*1.1*maxval(sflux_r(:,j)),maxval(ztexec),maxval(zqexec) !sflux_t(:,j) = ztexec(:) !sflux_r(:,j) = zqexec(:) !endif end if !-----memory !AA3(:,j)=cprr4d(:,j,deep) *fixout_qv(:) !AA2(:,j)=cprr4d(:,j,mid) *fixout_qv(:) end do end subroutine modConvParGFDriver !--------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------- subroutine cupGf(its, ite, kts, kte, itf, ktf, mtp, nmp, fscav & , cumulus & , ichoice & , entr_rate_input & , use_excess & !input data , dx & , stochastic_sig & , col_sat & , tke_pbl & , rh_dicycle_fct & , wlpool & , dtime & , kpbl & , ztexec & , zqexec & , ccn & , rho & , omeg & , t & , q & , z1 & , h_sfc_flux & , le_sfc_flux & , xlons & , xlats & , xland & , tn & , qo & , tn_bl & , qo_bl & , tn_adv & , qo_adv & , zo & , po & , tsur & , psur & , us & , vs & , dm2d & , se_chem & , zws & , dhdt & , buoy_exc & , mpqi & , mpql & , mpcf & , last_ierr & !output data , outt & , outq & , outqc & , outu & , outv & , outnliq & , outnice & , outbuoy & , outmpqi & , outmpql & , outmpcf & , out_chem & !- for convective transport , ierr & , jmin & , klcl & , k22 & , kbcon & , ktop & , kstabi & , kstabm & , pre & , xmb & , edto & , pwavo & , sig & , po_cup & , up_massentro & , up_massdetro & , dd_massentro & , dd_massdetro & , zuo & , zdo & , pwo & , pwdo & , qrco & , tup & , clfrac & !- for convective transport-end !- for debug/diag , aaa0_, aa1_, aa1_adv_, aa1_radpbl_, aa2_, aa3_, aa1_bl_, aa1_cin_, tau_bl_, tau_ec_ & , lightn_dens & , var2d & , revsu_gf & , prfil_gf & , var3d_agf & , var3d_bgf & , tpert & ) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupGf' ! Nome da subrotina logical, parameter:: p_use_inv_layers = .true. !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts & , kte, ichoice, use_excess & , mtp, nmp real, intent(in) :: col_sat(its:ite) real, intent(in) :: stochastic_sig(its:ite) real, intent(in) :: tke_pbl(its:ite) !- atmos composition arrays real, intent(in) :: fscav(mtp) real, intent(in) :: dtime real, intent(in) :: entr_rate_input character(len=*), intent(in) :: cumulus integer, intent(inout) :: kpbl(its:ite) integer, intent(inout) :: last_ierr(its:ite) integer, intent(inout) :: ierr(its:ite) integer, intent(inout) :: jmin(its:ite) integer, intent(inout) :: klcl(its:ite) integer, intent(inout) :: k22(its:ite) integer, intent(inout) :: kbcon(its:ite) integer, intent(inout) :: ktop(its:ite) integer, intent(inout) :: kstabi(its:ite) integer, intent(inout) :: kstabm(its:ite) real, intent(inout) :: outu(its:ite, kts:kte) real, intent(inout) :: outv(its:ite, kts:kte) real, intent(inout) :: outt(its:ite, kts:kte) !! output temp tendency (per s) real, intent(inout) :: outq(its:ite, kts:kte) !! output q tendency (per s) real, intent(inout) :: outqc(its:ite, kts:kte) !! output qc tendency (per s) real, intent(inout) :: outbuoy(its:ite, kts:kte) real, intent(inout) :: revsu_gf(its:ite, kts:kte) real, intent(inout) :: prfil_gf(its:ite, kts:kte) real, intent(inout) :: var3d_agf(its:ite, kts:kte) real, intent(inout) :: var3d_bgf(its:ite, kts:kte) real, intent(inout) :: outnliq(its:ite, kts:kte) real, intent(inout) :: outnice(its:ite, kts:kte) ! basic environmental input includes ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off ! convection for this call only and at that particular gridpoint real, intent(inout) :: buoy_exc(its:ite, kts:kte) real, intent(inout) :: ccn(its:ite) real, intent(inout) :: clfrac(its:ite, kts:kte) real, intent(inout) :: dd_massdetro(its:ite, kts:kte) real, intent(inout) :: dd_massentro(its:ite, kts:kte) real, intent(inout) :: dhdt(its:ite, kts:kte) real, intent(inout) :: dm2d(its:ite, kts:kte) real, intent(inout) :: dx(its:ite) real, intent(inout) :: edto(its:ite) real, intent(inout) :: h_sfc_flux(its:ite) real, intent(inout) :: le_sfc_flux(its:ite) real, intent(inout) :: mpcf(nmp, its:ite, kts:kte) real, intent(inout) :: mpqi(nmp, its:ite, kts:kte) real, intent(inout) :: mpql(nmp, its:ite, kts:kte) real, intent(inout) :: omeg(its:ite, kts:kte, 1:p_ens4) real, intent(inout) :: out_chem(mtp, its:ite, kts:kte) real, intent(inout) :: outmpcf(nmp, its:ite, kts:kte) real, intent(inout) :: outmpqi(nmp, its:ite, kts:kte) real, intent(inout) :: outmpql(nmp, its:ite, kts:kte) real, intent(inout) :: po_cup(its:ite, kts:kte) real, intent(inout) :: po(its:ite, kts:kte) real, intent(inout) :: psur(its:ite) real, intent(inout) :: pwavo(its:ite) real, intent(inout) :: pwdo(its:ite, kts:kte) real, intent(inout) :: pwo(its:ite, kts:kte) real, intent(inout) :: q(its:ite, kts:kte) !! environmental mixing ratio real, intent(inout) :: qo_adv(its:ite, kts:kte) real, intent(inout) :: qo_bl(its:ite, kts:kte) real, intent(inout) :: qo(its:ite, kts:kte) real, intent(inout) :: qrco(its:ite, kts:kte) real, intent(inout) :: rh_dicycle_fct(its:ite) real, intent(inout) :: rho(its:ite, kts:kte) real, intent(inout) :: se_chem(mtp, its:ite, kts:kte) real, intent(inout) :: t(its:ite, kts:kte) !! environmental temp real, intent(inout) :: tn_adv(its:ite, kts:kte) real, intent(inout) :: tn_bl(its:ite, kts:kte) real, intent(inout) :: tn(its:ite, kts:kte) real, intent(inout) :: tpert(its:ite, kts:kte) real, intent(inout) :: tsur(its:ite) real, intent(inout) :: tup(its:ite, kts:kte) real, intent(inout) :: up_massdetro(its:ite, kts:kte) real, intent(inout) :: up_massentro(its:ite, kts:kte) real, intent(inout) :: us(its:ite, kts:kte) real, intent(inout) :: vs(its:ite, kts:kte) real, intent(inout) :: wlpool(its:ite) real, intent(inout) :: xland(its:ite) real, intent(inout) :: xlats(its:ite) real, intent(inout) :: xlons(its:ite) real, intent(inout) :: xmb(its:ite) real, intent(inout) :: z1(its:ite) real, intent(inout) :: zdo(its:ite, kts:kte) real, intent(inout) :: zqexec(its:ite) real, intent(inout) :: ztexec(its:ite) real, intent(inout) :: zuo(its:ite, kts:kte) real, intent(inout) :: zws(its:ite) !-- debug/diag real, intent(inout) :: aaa0_(its:ite) real, intent(inout) :: aa1_(its:ite) real, intent(inout) :: aa1_adv_(its:ite) real, intent(inout) :: aa1_bl_(its:ite) real, intent(inout) :: aa1_cin_(its:ite) real, intent(inout) :: aa1_radpbl_(its:ite) real, intent(inout) :: aa2_(its:ite) real, intent(inout) :: aa3_(its:ite) real, intent(inout) :: tau_bl_(its:ite) real, intent(inout) :: tau_ec_(its:ite) real, intent(out) :: lightn_dens(its:ite) real, intent(out) :: pre(its:ite) real, intent(out) :: sig(its:ite) real, intent(out) :: var2d(its:ite) !Local variables: ! local ensemble dependent variables in this routine real, dimension(its:ite, 1:p_maxens2) :: edtc real, dimension(its:ite, 1:p_ensdim) :: xf_ens, pr_ens ! !*******the following are your basic environmental ! variables. They carry a "_cup" if they are ! on model cloud levels (staggered). They carry ! an "o"-ending (z becomes zo), if they are the forced ! variables. They are preceded by x (z becomes xz) ! to indicate modification by some typ of cloud ! ! z = heights of model levels ! qes = environmental saturation mixing ratio ! p = environmental pressure ! he = environmental moist static energy ! hes = environmental saturation moist static energy ! z_cup = heights of model cloud levels ! q_cup = environmental q on model cloud levels ! qes_cup = saturation q on model cloud levels ! t_cup = temperature (Kelvin) on model cloud levels ! p_cup = environmental pressure ! he_cup = moist static energy on model cloud levels ! hes_cup = saturation moist static energy on model cloud levels ! gamma_cup = gamma on model cloud levels ! ! ! hcd = moist static energy in downdraft ! zd normalized downdraft mass flux ! dby = buoancy term ! entr = entrainment rate ! zd = downdraft normalized mass flux ! entr= entrainment rate ! hcd = h in model cloud ! bu = buoancy term ! zd = normalized downdraft mass flux ! gamma_cup = gamma on model cloud levels ! qcd = cloud q (including liquid water) after entrainment ! qrch = saturation q in cloud ! pwd = evaporate at that level ! pwev = total normalized integrated evaoprate (I2) ! entr= entrainment rate ! z1 = terrain elevation ! entr = downdraft entrainment rate ! jmin = downdraft originating level ! kdet = level above ground where downdraft start detraining ! psur = surface pressure ! z1 = terrain elevation ! pr_ens = precipitation ensemble ! xf_ens = mass flux ensembles ! massfln = downdraft mass flux ensembles used in next timestep ! omeg = omega from large scale model ! mconv = moisture convergence from large scale model ! zd = downdraft normalized mass flux ! zu = updraft normalized mass flux ! dir = "storm motion" ! mbdt = arbitrary numerical parameter ! dtime = dt over which forcing is applied ! iact_gr_old = flag to tell where convection was active ! kbcon = LFC of parcel from k22 ! k22 = updraft originating level ! ichoice = flag if only want one closure (usually set to zero!) ! dby = buoancy term ! ktop = cloud top (output) ! xmb = total base mass flux ! hc = cloud moist static energy ! hkb = moist static energy at originating level integer, dimension(its:ite) :: kzdown, kdet, kb, ierr2 & , ierr3, kbmax, ierr_dummy & , start_level integer, dimension(its:ite, kts:kte) :: k_inv_layers integer :: iloop, nall, iedt, nens, nens3, ki, i, k, KK, iresult, nvar, nvarbegin integer :: jprnt, k1, k2, kbegzu, kdefi, kfinalzu, kstart, jmini, imid, k_free_trop integer :: iversion, step, fase, start_k22, ispc, kmp, istep, lstep, status integer :: X_kte, X_k, X_i, X_jcol integer :: i_wb = 0,ipr = 0, jpr = 0, bl = 1, fa = 2 real, dimension(its:ite) :: edtx, hkb, hkbo, xhkb, qkb, pwevo & , bu, bud, cap_max, xland1, vshear & , cap_max_increment, psum, psumh, sigd & , mconv, rescale_entrain, entr_rate & , mentrd_rate, aa0_bl, aa1_bl, tau_bl & , tau_ecmwf, wmean, aa1_fa, aa1_tmp, hkbo_x & , aa2, aa3, cin0, cin1, edtmax, edtmin & , aa1_lift, aa_tmp, aa_ini, aa_adv & , daa_adv_dt, wlpool_bcon, xaa0_x, xk_x & , xf_dicycle, mbdt, xf_coldpool, vvel1d & , x_add_buoy, lambau_dn, lambau_dp & , q_wetbulb, t_wetbulb, col_sat_adv & , q_adv, alpha_adv, aa1_radpbl, aa1_adv & , p_cwv_ave, cape, depth_neg_buoy, frh_bcon & , check_sig, random, rh_entr_factor real, dimension(its:ite) :: aa0 !! cloud work function without forcing effects real, dimension(its:ite) :: aa1 !! cloud work function with forcing effects real, dimension(its:ite) :: xaa0 !! cloud work function with cloud effects real, dimension(its:ite) :: edt !! epsilon real, dimension(kts:kte) :: dummy1, dummy2 real, dimension(its:ite, kts:kte) :: entr_rate_2d, mentrd_rate_2d & , he, hes, qes, z, heo, heso, qeso, zo, zu, zd & , xhe, xhes, xqes, xz, xt, xq & , qes_cup, q_cup, he_cup, hes_cup, z_cup, p_cup, gamma_cup, t_cup & , qeso_cup, qo_cup, heo_cup, heso_cup, zo_cup, gammao_cup, tn_cup & , xqes_cup, xq_cup, xhe_cup, xhes_cup, xz_cup & , xt_cup, hcot, evap_bcb & , dby, hc, clw_all & , dbyo, qco, qrcdo, hcdo, qcdo, dbydo, hco & , xdby, xzu, xzd, xhc, cupclw, pwo_eff & , dsubq, dsubh, dellabuoy, u_cup, v_cup, uc & , vc, ucd, vcd, dellu, dellv, up_massentr & , up_massdetr, dd_massentr, dd_massdetr & , subten_h, subten_q, subten_t real, dimension(its:ite, kts:kte) :: tn_x, qo_x, qeso_x, heo_x, heso_x, zo_cup_x & , qeso_cup_x, qo_cup_x, heo_cup_x, heso_cup_x & , po_cup_x, gammao_CUP_x, tn_cup_x, hco_x, DBYo_x & , u_cup_x, v_cup_x, xhe_x, xhes_x, xt_x, xq_x & , xqes_x, xqes_cup_x, xq_cup_x, xhe_cup_x & , xhes_cup_x, gamma_cup_x, xt_cup_x, dtempdz & , vvel2d, tempco, tempcdo, p_liq_ice, melting_layer & , melting, c1d, up_massentru, up_massdetru & , dd_massentru, dd_massdetru, prec_flx, evap_flx & , qrr, massflx, zenv, rho_hydr, dtdt, dqdt !alpha_h, alpha_q real, dimension(its:ite, kts:kte) :: cd !! detrainment function for updraft real, dimension(its:ite, kts:kte) :: cdd !! detrainment function for downdraft real, dimension(its:ite, kts:kte) :: dellah !! real, dimension(its:ite, kts:kte) :: dellaq !! change of q per unit mass flux of cloud ensemble real, dimension(its:ite, kts:kte) :: dellat !! change of temperature per unit mass flux of cloud ensemble real, dimension(its:ite, kts:kte) :: dellaqc !! change of qc per unit mass flux of cloud ensemble real, dimension(its:ite, 1:p_maxens3) :: xff_mid real, dimension(its:ite, p_shall_closures) :: xff_shal real, dimension(mtp, its:ite, kts:kte) :: se_cup_chem, sc_up_chem, sc_dn_chem & , pw_up_chem, pw_dn_chem real, dimension(mtp, its:ite) :: tot_pw_up_chem, tot_pw_dn_chem real, dimension(mtp, kts:kte) :: trcflx_in, sub_tend, ddtr, ddtr_upd, zenv_diff & , fp_mtp, fm_mtp real, dimension(mtp) :: min_tend_chem, dummy_chem, delS_up, delS_dn, env_sub & , outchem1, evap_, wetdep_, trash_, trash2_, residu_ real, dimension(nmp, its:ite, kts:kte) :: dellampqi, dellampql, dellampcf real, dimension(kts:kte) :: aa, bb, cc, ddu, ddv, ddh, ddq, fp, fm real, dimension(nmp, kts:kte) :: dd real, dimension(its:ite) :: x_dx, x_stochastic_sig real, dimension(kts:kte, 8) :: tend2d real, dimension(8) :: tend1d real, dimension(its:ite, 8) :: check_cons_i, check_cons_f !-- only for debug (atmos composition) real, allocatable, dimension(:, :, :), save :: se_chem_update real :: massi, massf, dtime_max, evap, wetdep, umean real :: day, dz, dzo, radius, entrd_rate, zcutdown, depth_min, zkbmax & , z_detr, zktop, massfld, dh, trash, frh, xlamdd, radiusd, frhd & , effec_entrain, detdo1, detdo2, entdo, dp, subin, detdo, entup & , detup, subdown, entdoj, entupk, detupk, totmas, min_entr_rate real :: tot_time_hr, beta, env_mf, env_mf_p, env_mf_m, ts, denom, denom_u real :: dsubh_aver, dellah_aver, x_add, cap_max_inc, tlll, plll, rlll & , tlcl, plcl, dzlcl, zlll, c_up, e_dn, g_rain, trash2, pgc, bl2dp & , trash3, ke_mx, s1, s2, q1, q2, rz_env, factor, cwv, entr_threshold & , resten_h, resten_q, resten_t, min_deep_top, min_shall_top real :: alp0, beta1, beta2, dp_p, dp_m, delt1, delt2, delt_tvv, rcount logical :: keep_going character(len=128) :: ierrc(its:ite) character(len=2) :: cty character(len=200) :: lixo !---------------------------------------------------------------------- !--only for debug if (p_use_gate) then if (.not. allocated(se_chem_update)) allocate (se_chem_update(3, its:ite, kts:kte)) if (jl == 1) then ! se_chem_update(1,:,:) = mpql (lsmp,:,:) ! se_chem_update(2,:,:) = mpqi (lsmp,:,:) ! se_chem_update(3,:,:) = mpcf (lsmp,:,:) else ! mpql (lsmp,:,:)= se_chem_update(1,:,:) ! mpqi (lsmp,:,:)= se_chem_update(2,:,:) ! mpcf (lsmp,:,:)= se_chem_update(3,:,:) end if end if !--- maximum depth (mb) of capping inversion (larger cap = no convection) if (MOIST_TRIGGER == 0) then if (trim(cumulus) == 'deep') then cap_max_inc = 20. end if if (trim(cumulus) == 'mid') then cap_max_inc = 10. end if if (trim(cumulus) == 'shallow') then cap_max_inc = 25. end if else if (trim(cumulus) == 'deep') then cap_max_inc = 90. end if if (trim(cumulus) == 'mid') then cap_max_inc = 90. end if if (trim(cumulus) == 'shallow') then cap_max_inc = 10. end if end if ! !--- lambda_U parameter for momentum transport ! if (trim(cumulus) == 'deep') then lambau_dp(:) = LAMBAU_DEEP lambau_dn(:) = LAMBAU_SHDN end if if (trim(cumulus) == 'mid') then lambau_dp(:) = LAMBAU_SHDN lambau_dn(:) = LAMBAU_SHDN end if if (trim(cumulus) == 'shallow') then lambau_dp(:) = LAMBAU_SHDN lambau_dn(:) = LAMBAU_SHDN end if if (p_pgcon .ne. 0.) then lambau_dp(:) = 0. lambau_dn(:) = 0. end if do i = its, itf kbmax(i) = 1 kstabm(i) = ktf - 1 ierr2(i) = 0 ierr3(i) = 0 xland1(i) = xland(i) ! 1. cap_max(i) = CAP_MAXS ierrc(i) = "ierrtxt" aa0(i) = 0.0 aa1(i) = 0.0 aa2(i) = 0.0 aa3(i) = 0.0 aa1_bl(i) = 0.0 aa1_fa(i) = 0.0 aa0_bl(i) = 0.0 q_adv(i) = 0.0 aa1_radpbl(i) = 0.0 aa1_adv(i) = 0.0 alpha_adv(i) = 0.0 cin1(i) = 0.0 xk_x(i) = 0.0 edt(i) = 0.0 edto(i) = 0.0 tau_bl(i) = 0.0 q_wetbulb(i) = 0.0 t_wetbulb(i) = 0.0 tau_ecmwf(i) = 0.0 xf_dicycle(i) = 0.0 x_add_buoy(i) = 0.0 xf_coldpool(i) = 0.0 wlpool_bcon(i) = 0.0 z(i, :) = zo(i, :) xz(i, :) = zo(i, :) hcdo(i, :) = 0.0 cupclw(i, :) = 0.0 qrcdo(i, :) = 0.0 hcot(i, :) = 0.0 c1d(i, :) = 0.0 xf_ens(i, :) = 0.0 pr_ens(i, :) = 0.0 evap_bcb(i, :) = 0.0 cap_max_increment(i) = cap_max_inc end do !--- create a real random number in the interval [-use_random_num, +use_random_num] if (trim(cumulus) == 'deep' .and. USE_RANDOM_NUM > 1.e-6) then random = genRandom(its, ite, USE_RANDOM_NUM) else random = 0.0 end if !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft ! base mass flux !-- note : to make the evaporation stronger => increase "edtmin" if (trim(cumulus) == 'shallow') then edtmin(:) = 0.0 edtmax(:) = 0.0 end if if (trim(cumulus) == 'mid') then do i = its, itf if (xland(i) > 0.99) then !- over water edtmin(i) = 0.1 edtmax(i) = max_edt_ocean ! else!- over land edtmin(i) = 0.1 edtmax(i) = max_edt_land ! end if end do if (C0_MID < 1.e-8) edtmin(:) = 0.0 end if if (trim(cumulus) == 'deep') then do i = its, itf if (xland(i) > 0.99) then !- over water edtmin(i) = 0.1 edtmax(i) = max_edt_ocean ! else!- over land edtmin(i) = 0.1 edtmax(i) = max_edt_land ! end if end do end if !--- minimum depth (m), clouds must have if (trim(cumulus) == 'deep') depth_min = 1000. if (trim(cumulus) == 'mid' .or. trim(cumulus) == 'shallow') depth_min = 500. !--- max height(m) above ground where updraft air can originate if (trim(cumulus) == 'deep') zkbmax = 4000. if (trim(cumulus) == 'mid' .or. trim(cumulus) == 'shallow') zkbmax = 3000. !--- height(m) above which no downdrafts are allowed to originate zcutdown = 3000. !--- depth(m) over which downdraft detrains all its mass z_detr = 1000. if (trim(cumulus) == 'deep') z_detr = 1000. if (trim(cumulus) == 'mid' .or. trim(cumulus) == 'shallow') z_detr = 300. !--- mbdt ~ xmb * timescale do i = its, itf mbdt(i) = 0.1!*dtime*xmb_nm1(i) !mbdt(i)= 100.*(p_cup(i,kbcon(i))-p_cup(i,kbcon(i)+1))/(g*dtime) !mbdt(i)= 0.1*mbdt(i) end do !--- environmental conditions, FIRST HEIGHTS !--- calculate moist static energy, heights, qes call cupEnv(z, qes, he, hes, t, q, po, z1, psur, ierr, -1, itf, ktf, its, ite, kts, kte) call cupEnv(zo, qeso, heo, heso, tn, qo, po, z1, psur, ierr, -1, itf, ktf, its, ite, kts, kte) !--- outputs a model sounding for the stand-alone code (part 1) if (output_sound == 1) then call sound(1, cumulus, int_time, dtime, p_ens4, itf, ktf, its, ite, kts, kte, xlats, xlons, jcol, whoami_all & , z, qes, he, hes, t, q, po, z1, psur, zo, qeso, heo, heso, tn, qo, us, vs, omeg, xz & , h_sfc_flux, le_sfc_flux, tsur, dx, stochastic_sig, zws, ztexec, zqexec, xland & , kpbl, k22, klcl, kbcon, ktop, aa0, aa1, sig, xaa0, hkb, xmb, pre, edto & , zo_cup, dhdt, rho, zuo, zdo, up_massentro, up_massdetro, outt, outq, outqc, outu, outv) end if !--- environmental values on cloud levels call cupEnvCLev(t, qes, q, he, hes, z, po, qes_cup, q_cup, he_cup, us, vs, u_cup, v_cup, hes_cup, z_cup, p_cup & , gamma_cup, t_cup, psur, tsur, ierr, z1, itf, ktf, its, ite, kts, kte) call cupEnvCLev(tn, qeso, qo, heo, heso, zo, po, qeso_cup, qo_cup, heo_cup, us, vs, u_cup, v_cup, heso_cup, zo_cup & , po_cup, gammao_cup, tn_cup, psur, tsur, ierr, z1, itf, ktf, its, ite, kts, kte) !--- get air density at full layer (model levels) by hydrostatic balance (kg/m3) do i = its, itf rho_hydr(i, :) = 0.0 if (ierr(i) /= 0) cycle do k = kts, ktf rho_hydr(i, k) = 100.*(po_cup(i, k) - po_cup(i, k + 1))/(zo_cup(i, k + 1) - zo_cup(i, k))/c_grav !print*,"rhohidr=",k,rho_hydr(i,k),po_cup(i,k+1),zo_cup(i,k+1) end do end do !--- partition between liq/ice cloud contents call getPartitionLiqIce(ierr, tn, z1, zo_cup, po_cup, p_liq_ice, melting_layer, itf, ktf, its, ite, kts, kte, cumulus) do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktf if (zo_cup(i, k) .gt. zkbmax + z1(i)) then kbmax(i) = k exit end if end do !--- level where detrainment for downdraft starts do k = kts, ktf if (zo_cup(i, k) .gt. z_detr + z1(i)) then kdet(i) = k exit end if end do end do !--- determine level with highest moist static energy content - k22 if (trim(cumulus) == 'shallow') then start_k22 = 1 else start_k22 = 2 end if k22(:) = kts do i = its, itf if (ierr(i) /= 0) cycle k22(i) = maxloc(heo_cup(i, start_k22:kbmax(i) + 1), 1) + start_k22 - 1 k22(i) = max(k22(i), start_k22) if (trim(cumulus) == 'shallow') then k22(i) = min(2, k22(i)) if (K22(i) .gt. kbmax(i)) then ierr(i) = 2 ierrc(i) = "could not find k22" end if else if (k22(i) > kbmax(i)) then !- let's try k22=start_k22 for the cases k22>kbmax k22(i) = start_k22 cycle end if end if end do !-- get the pickup of ensemble ave prec, following Neelin et al 2009. call precipCwvFactor(itf, ktf, its, ite, kts, kte, ierr, tn, po, qo, po_cup, cumulus, p_cwv_ave) !------- determine LCL for the air parcels around K22 do i = its, itf klcl(i) = k22(i) ! default value if (ierr(i) == 0) then !tlll, rlll,plll - temp, water vapor and pressure of the source air parcel x_add = max(0., zqexec(i)) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), q_cup(i, kts:kte), rlll, k22(i), x_add) x_add = max(0., ztexec(i)) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), t_cup(i, kts:kte), tlll, k22(i), x_add) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), p_cup(i, kts:kte), plll, k22(i)) !-get LCL call getLcl(tlll, 100.*plll, rlll, tlcl, plcl, dzlcl) if (dzlcl >= 0.) then ! LCL found (if dzlcl<0 => not found) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), z_cup(i, kts:kte), zlll, k22(i)) do k = kts, ktf if (z_cup(i, k) .gt. zlll + dzlcl) then klcl(i) = max(k, k22(i)) exit end if end do klcl(i) = min(klcl(i), ktf - 4) end if end if !write(12,111)'MDlcl',tlcl,plcl,dzlcl,klcl(i),ierr(i) !111 format(1x,A5,3F10.2,2i4) end do !-- check if LCL height is below PBL height to allow shallow convection if (LCL_TRIGGER > 0 .and. trim(cumulus) == 'shallow') then do i = its, itf if (ierr(i) /= 0) cycle if (klcl(i) > max(1, kpbl(i) - LCL_TRIGGER)) then ierr(i) = 21 ierrc(i) = 'for shallow convection: LCL height < PBL height' end if end do !print*,"LCL",maxval(klcl),minval(klcl),maxval(kpbl),minval(kpbl) end if !--- define entrainment/detrainment profiles for updrafts !- initial entrainment/detrainment entr_rate(:) = entr_rate_input min_entr_rate = entr_rate_input*0.1 !-- cold pool parameterization and convective memory if (CONVECTION_TRACER == 1 .and. trim(cumulus) == 'deep') then if (USE_MEMORY >= 0) then do i = its, itf if (ierr(i) /= 0) cycle !x_add_buoy(i) = min(mx_buoy2, maxval(buoy_exc(i,kts:klcl(i)))) call getCloudBc(trim(cumulus), kts, kte, ktf, xland(i), po(i, kts:kte), buoy_exc(i, kts:kte), x_add_buoy(i), kts) ! buoy_exc (i,kts:kte),x_add_buoy (i),klcl(i)) end do !print*,"BU=",maxval(x_add_buoy),minval(x_add_buoy) end if !-- avoid extra-buoyancy where rained before if (USE_MEMORY == 1 .or. USE_MEMORY == 12) then where (aa2_ > 10./3600.) x_add_buoy = 0.0 wlpool = 0.0 end where end if !-- avoid extra-buoyancy where rained before if (USE_MEMORY == 4 .or. USE_MEMORY == 14) then do i = its, itf if (ierr(i) /= 0) cycle if (aa2_(i) > 1.e-6 .and. x_add_buoy(i) < 1000. .and. x_add_buoy(i) > 250.) then x_add_buoy(i) = 0.0 wlpool(i) = 0.0 ierr(i) = 100 end if end do !where(AA2_ > 1.e-6. .and. x_add_buoy < 1000.) ! x_add_buoy = 0.0 ! wlpool = 0.0 ! ierr = 100 !end where end if if (USE_MEMORY == 2 .or. USE_MEMORY == 12 .or. USE_MEMORY == 14) then !- initial entrainment/detrainment entr_rate(:) = entr_rate_input !* 2.0 min_entr_rate = entr_rate_input*0.1 !* 2.0 do i = its, itf !-- reduce entr rate, where cold pools exist if (ierr(i) /= 0) cycle !entr_rate(i) = max(0.1, 1.-ColdPoolStart(x_add_buoy(i))) * entr_rate(i) !entr_rate(i) = max(0.5, 1.-ColdPoolStart(x_add_buoy(i))) * entr_rate(i) entr_rate(i) = max(0.7, 1.-ColdPoolStart(x_add_buoy(i)))*entr_rate(i) !entr_rate(i) = max(0.8, 1.-ColdPoolStart(x_add_buoy(i))) * entr_rate(i) end do !print*,"ENT",1000.*maxval(entr_rate),1000.*minval(entr_rate)& ! ,ColdPoolStart(maxval((x_add_buoy(:)))),ColdPoolStart(minval((x_add_buoy(:)))) end if if (USE_MEMORY == 3 .or. ADD_COLDPOOL_CLOS >= 1) then ! increase capmax do i = its, itf if (ierr(i) /= 0) cycle cap_max(i) = cap_max(i) + ColdPoolStart(x_add_buoy(i))*35. end do end if if (ADD_COLDPOOL_CLOS == 3) then ! increase x_add_buoy do i = its, itf if (ierr(i) /= 0) cycle x_add_buoy(i) = x_add_buoy(i) + 0.5*wlpool(i)**2 end do end if !--- temporary for output if (USE_GUSTINESS == 0) aa3_(:) = x_add_buoy(:) if (USE_GUSTINESS == 4) then aa3_(:) = x_add_buoy(:); x_add_buoy(:) = 0.0 end if !-- using ztexc and zqexc as perturbation: if (USE_GUSTINESS == 1 .or. USE_GUSTINESS == 2) then aa3_(:) = real(c_cp)*ztexec(:) + real(c_xlv)*zqexec(:) x_add_buoy(:) = 0. end if end if ! !--- determine the entrainment dependent on environmental moist (here relative humidity) !--- also the controls of RH on the diurnal cycle (see Tian et al 2022 GRL) if (trim(cumulus) == 'deep') call rhControls(itf, ktf, its, ite, kts, kte, ierr, tn, po, qo, qeso, po_cup, cumulus & , rh_entr_factor, rh_dicycle_fct, entr_rate_input, entr_rate, xlons, dtime) !--- determine the vertical entrainment/detrainment rates, the level of convective cloud base -kbcon- !--- and the scale dependence factor (sig). do i = its, itf entr_rate_2d(i, :) = entr_rate(i) cd(i, :) = entr_rate(i) if (ierr(i) /= 0) cycle if (trim(cumulus) /= 'shallow') then do k = kts, ktf frh = min(qo_cup(i, k)/qeso_cup(i, k), 1.) !------------------------------------------- if (p_entr_new) then !- v 2 if (k >= klcl(i)) then !entr_rate_2d(i,k)=entr_rate(i)*(1.3-frh)*(qeso_cup(i,k)/qeso_cup(i,klcl(i)))**3 entr_rate_2d(i, k) = entr_rate(i)*(1.3 - frh)*(qeso_cup(i, k)/qeso_cup(i, klcl(i)))**1.25 else entr_rate_2d(i, k) = entr_rate(i)*(1.3 - frh) end if cd(i, k) = 0.75e-4*(1.6 - frh) entr_rate_2d(i, k) = max(entr_rate_2d(i, k), min_entr_rate) else !- v 1 entr_rate_2d(i, k) = max(entr_rate(i)*(1.3 - frh)*max(min(1., (qeso_cup(i, k) & / qeso_cup(i, klcl(i)))**1.25), 0.1), 1.e-5) if (trim(cumulus) == 'deep') cd(i, k) = 1.e-2*entr_rate(i) if (trim(cumulus) == 'mid') cd(i, k) = 0.75*entr_rate_2d(i, k) end if end do else do k = kts, ktf frh = min(qo_cup(i, k)/qeso_cup(i, k), 1.) !entr_rate_2d(i,k)=entr_rate(i)*(1.3-frh)*max(min(1.,(qeso_cup(i,max(k,klcl(i)))& ! /qeso_cup(i,klcl(i)))**3) ,0.1) entr_rate_2d(i, k) = entr_rate(i)*(1.3 - frh)*max(min(1., (qeso_cup(i, max(k, klcl(i))) & / qeso_cup(i, klcl(i)))**1), 0.1) ! entr_rate_2d(i,k)=entr_rate(i)*(1.3-frh)*(min(z(i,klcl(i))/z(i,k),1.)) ! entr_rate_2d(i,k) = max(entr_rate_2d(i,k),min_entr_rate) !print*,"ent=",k,real(z(i,k),4),real(min(z(i,klcl(i))/z(i,k),1.),4),real(entr_rate_2d(i,k)*1000.,4) cd(i, k) = 0.75*entr_rate_2d(i, k)!+0.5e-3 end do end if end do !--- start_level start_level(:) = klcl(:) !start_level(:)= KTS !--- determine the moist static energy of air parcels at source level do i = its, itf if (ierr(i) /= 0) cycle x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), he_cup(i, kts:kte), hkb(i), k22(i), x_add & , tpert(i, kts:kte)) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), heo_cup(i, kts:kte), hkbo(i), k22(i), x_add & , tpert(i, kts:kte)) !print*,"xi=",i, xlv*zqexec(i)+cp*ztexec(i) , x_add_buoy(i), hkbo(i) end do ! !--- determine the level of convective cloud base - kbcon call cupCloudLimits(cumulus, ierrc, ierr, cap_max_increment, cap_max, heo_cup, heso_cup, qo_cup & , qeso_cup, po, po_cup, zo_cup, heo, hkbo, qo, qeso, entr_rate_2d, hcot, k22, kbmax & , klcl, kbcon, ktop, depth_neg_buoy, frh_bcon, tpert, start_level & , use_excess, zqexec, ztexec, x_add_buoy, xland, itf, ktf, its, ite, kts, kte) !--- scale dependence factor (sig), version new if (USE_SCALE_DEP == 0 .or. trim(cumulus) == 'shallow') then sig(:) = 1. else do i = its, itf sig(i) = 0. if (ierr(i) /= 0) cycle !--original !sig(i) = 1.0-0.9839*exp(-0.09835. *(dx(i)/1000.)) !-- for similar curve as in IFS/EC, use sig_factor = 0.22 sig(i) = 1.0 - exp(-SIG_FACTOR*(dx(i)/1000.)) !print*,"sig=",sig(i),dx(i), sig_factor if (stochastic_sig(i) /= 1.0) then sig(i) = sig(i)**(stochastic_sig(i)*max(0.9, 0.9*sig(i))) end if sig(i) = max(0.001, min(sig(i), 1.)) end do !print*,'sig',maxval(sig),minval(sig),maxval(dx),minval(dx) end if !--- define entrainment/detrainment profiles for downdrafts if (p_entr_new) then mentrd_rate(:) = entr_rate(:)*0.3 else mentrd_rate(:) = entr_rate(:) end if do i = its, itf cdd(i, kts:kte) = mentrd_rate(i) end do !- scale dependence factor sigd(:) = 1. if (DOWNDRAFT == 0) sigd(:) = 0.0 !--- update hkb/hkbo in case of k22 is redefined in 'cup_kbon' do i = its, itf if (ierr(i) /= 0) cycle x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), he_cup(i, kts:kte), hkb(i), k22(i), x_add & , tpert(i, kts:kte)) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), heo_cup(i, kts:kte), hkbo(i), k22(i), x_add & , tpert(i, kts:kte)) end do !--- increase detrainment in stable layers call cupMinimi(HEso_cup, Kbcon, kstabm, kstabi, ierr, itf, ktf, its, ite, kts, kte) !--- option for using the inversion layers as a barrier for the convection development if (trim(cumulus) == 'mid') then if (p_use_inv_layers) then !--- get inversion layers call getInversionLayers(cumulus, ierr, psur, po_cup, tn_cup, zo_cup, k_inv_layers, dtempdz, itf, ktf, its, ite & , kts, kte) do i = its, itf if (ierr(i) /= 0) cycle ktop(i) = min(ktop(i), k_inv_layers(i, p_mid)) !print*,"ktop=",ktop(i),k_inv_layers(i,mid) end do end if !-- check if ktop is above 450hPa layer for mid convection do i = its, itf if (ierr(i) /= 0) cycle !print*,"sta=",Kbcon(i),kstabm(i),kstabi(i),p_cup(i,ktop(i)),z_cup(i,kstabi(i)) if (po_cup(i, ktop(i)) < 450.) then ierr(i) = 25 ierrc(i) = 'mid convection with cloud top above 450 hPa (~ 7km asl)' end if end do !-- check if ktop is below 750hPa layer for mid convection do i = its, itf if (ierr(i) /= 0) cycle if (po_cup(i, ktop(i)) > 750.) then ierr(i) = 55 ierrc(i) = 'ktop too low for mid' end if end do end if if (trim(cumulus) == 'shallow') then if (p_use_inv_layers) then call getInversionLayers(cumulus, ierr, psur, po_cup, tn_cup, zo_cup, k_inv_layers, dtempdz, itf, ktf, its, ite, kts & , kte) do i = its, itf if (ierr(i) /= 0) cycle ktop(i) = min(ktop(i), k_inv_layers(i, p_shal)) end do end if !--- Check if ktop is above 700hPa layer for shallow convection do i = its, itf if (ierr(i) /= 0) cycle min_shall_top = 700. !if(icumulus_gf(mid) == 0) min_shall_top=500. if (po_cup(i, ktop(i)) < min_shall_top) then ierr(i) = 26 ierrc(i) = 'shallow convection wit h cloud top above min_shall_top hPa' end if end do end if do i = its, itf if (ktop(i) <= kbcon(i)) then ierr(i) = 5 ierrc(i) = 'ktop too small' end if end do if (trim(cumulus) == 'deep') then min_deep_top = 500. if (ICUMULUS_GF(p_mid) == 0) min_deep_top = 750. do i = its, itf if (ierr(i) /= 0) cycle if (po_cup(i, ktop(i)) > min_deep_top) then ierr(i) = 55 ierrc(i) = 'ktop too low for deep' end if end do end if !-- avoid double-counting with shallow scheme (deep and mid) do i = its, itf if (ierr(i) /= 0) cycle if (last_ierr(i) == 0) then !--- if 'mid' => last was 'shallow' ! if(cumulus == 'mid' .and. po_cup(i,ktop(i)) > 700.) then ! ierr(i)=27 ! ierrc(i)='avoiding double-counting shallow and mid' ! endif !--- if 'mid' => last was 'shallow' if (trim(cumulus) == 'mid') then ierr(i) = 27 ierrc(i) = 'avoiding double-counting deep and mid' end if end if end do !--- determine the normalized mass flux profile for updraft do i = its, itf zuo(i, :) = 0. if (ierr(i) /= 0) cycle call getZuZdPdf(trim(cumulus), trim(cumulus)//"_up", ierr(i), k22(i), ktop(i), zuo(i, kts:kte), kts, kte, ktf & , kpbl(i), k22(i), kbcon(i), klcl(i), po_cup(i, kts:kte), psur(i), xland(i), random(i)) end do do i = its, itf if (ierr(i) /= 0) cycle xzu(i, :) = zuo(i, :) zu(i, :) = zuo(i, :) end do ! calculate mass entrainment and detrainment call getLateralMassFlux(itf, ktf, its, ite, kts, kte, min_entr_rate, ierr, ktop, zo_cup, zuo, cd, entr_rate_2d, po_cup & , up_massentro, up_massdetro, up_massentr, up_massdetr, cumulus, kbcon, k22, kpbl, up_massentru & , up_massdetru, lambau_dp) uc = 0. vc = 0. hc = 0. hco = 0. do i = its, itf if (ierr(i) .eq. 0) then do k = kts, start_level(i) hc(i, k) = hkb(i) hco(i, k) = hkbo(i) !-get uc and vc as average between layers below k22 call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), u_cup(i, kts:kte), uc(i, k), k22(i)) call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), v_cup(i, kts:kte), vc(i, k), k22(i)) end do end if end do !--- 1st guess for moist static energy and dbyo (not including ice phase) do i = its, itf if (ierr(i) /= 0) cycle do k = start_level(i) + 1, ktop(i) + 1 ! mass cons option denom = (zu(i, k - 1) - .5*up_massdetro(i, k - 1) + up_massentro(i, k - 1)) if (denom > 0.0) then hco(i, k) = (hco(i, k - 1)*zuo(i, k - 1) - .5*up_massdetro(i, k - 1)*hco(i, k - 1) + up_massentro(i, k - 1) & * heo(i, k - 1))/denom if (k == start_level(i) + 1) then x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) hco(i, k) = hco(i, k) + x_add*up_massentro(i, k - 1)/denom end if else hco(i, k) = hco(i, k - 1) end if end do do k = ktop(i) + 2, ktf hco(i, k) = heso_cup(i, k)!=heo_cup(i,k) end do end do !--- Get buoyancy of updrafts call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, hco, heo_cup, heso_cup, dbyo, zo_cup) !--- get "c1d" profile ---------------------------------------- if (trim(cumulus) == 'deep' .and. use_c1d) then do i = its, itf if (ierr(i) /= 0) cycle c1d(i, kbcon(i) + 1:ktop(i) - 1) = abs(C1) end do end if if (first_guess_w .or. AUTOCONV == 4) then call cupUpMoistureLight(cumulus, start_level, klcl, ierr, ierrc, zo_cup, qco, qrco, pwo, pwavo, hco, tempco, xland & , po, p_cup, kbcon, ktop, cd, dbyo, clw_all, t_cup, qo, gammao_cup, zuo & , qeso_cup, k22, qo_cup, zqexec, use_excess, rho, up_massentr, up_massdetr & , psum, psumh, c1d, x_add_buoy, 1, itf, ktf, ipr, jpr, its, ite, kts, kte) call cupUpVVel(vvel2d, vvel1d, zws, entr_rate_2d, cd, zo, zo_cup, zuo, dbyo, gammao_cup, tn_cup, tempco, qco, qrco, qo & , start_level, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte, wlpool, wlpool_bcon, 1) end if !--- calculate moisture properties of updraft call cupUpMoisture(cumulus, start_level, klcl, ierr, ierrc, zo_cup, qco, qrco, pwo, pwavo, hco, tempco, xland & , po, p_cup, kbcon, ktop, cd, dbyo, clw_all, t_cup, qo, gammao_cup, zuo, qeso_cup & , k22, qo_cup, zqexec, use_excess, ccn, rho, up_massentr, up_massdetr, psum & , psumh, c1d, x_add_buoy, vvel2d, vvel1d, zws, entr_rate_2d & , 1, itf, ktf, ipr, jpr, its, ite, kts, kte) do i = its, itf if (ierr(i) /= 0) cycle cupclw(i, kts:ktop(i) + 1) = qrco(i, kts:ktop(i) + 1) end do !--- get melting profile call getMeltingProfile(ierr, tn_cup, po_cup, p_liq_ice, melting_layer, qrco, pwo, edto, pwdo, melting, itf, ktf, its, ite & , kts, kte, cumulus) !--- updraft moist static energy + momentum budget !--- option to produce linear fluxes in the sub-cloud layer. if (trim(cumulus) == 'shallow' .and. USE_LINEAR_SUBCL_MF == 1) then do i = its, itf if (ierr(i) /= 0) cycle call getDelmix(cumulus, kts, kte, ktf, xland(i), start_level(i), po(i, kts:kte), he_cup(i, kts:kte), hc(i, kts:kte)) call getDelmix(cumulus, kts, kte, ktf, xland(i), start_level(i), po(i, kts:kte) , heo_cup(i, kts:kte), hco(i, kts:kte)) end do end if do i = its, itf if (ierr(i) /= 0) cycle do k = start_level(i) + 1, ktop(i) + 1 ! mass cons option denom = (zu(i, k - 1) - .5*up_massdetr(i, k - 1) + up_massentr(i, k - 1)) denom_u = (zu(i, k - 1) - .5*up_massdetru(i, k - 1) + up_massentru(i, k - 1)) if (denom > 0.0 .and. denom_u > 0.0) then hc(i, k) = (hc(i, k - 1)*zu(i, k - 1) - .5*up_massdetr(i, k - 1)*hc(i, k - 1) + & up_massentr(i, k - 1)*he(i, k - 1))/denom hco(i, k) = (hco(i, k - 1)*zuo(i, k - 1) - .5*up_massdetro(i, k - 1)*hco(i, k - 1) + & up_massentro(i, k - 1)*heo(i, k - 1))/denom if (k == start_level(i) + 1) then x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) hco(i, k) = hco(i, k) + x_add*up_massentro(i, k - 1)/denom hc(i, k) = hc(i, k) + x_add*up_massentr(i, k - 1)/denom end if !assuming zuo=zu,up_massdetro=up_massdetr, ... !(zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) uc(i, k) = (uc(i, k - 1)*zu(i, k - 1) - .5*up_massdetru(i, k - 1)*uc(i, k - 1) + & up_massentru(i, k - 1)*us(i, k - 1) & - p_pgcon*.5*(zu(i, k) + zu(i, k - 1))*(u_cup(i, k) - u_cup(i, k - 1)))/denom_u vc(i, k) = (vc(i, k - 1)*zu(i, k - 1) - .5*up_massdetru(i, k - 1)*vc(i, k - 1) + & up_massentru(i, k - 1)*vs(i, k - 1) & - p_pgcon*.5*(zu(i, k) + zu(i, k - 1))*(v_cup(i, k) - v_cup(i, k - 1)))/denom_u else hc(i, k) = hc(i, k - 1) hco(i, k) = hco(i, k - 1) uc(i, k) = uc(i, k - 1) vc(i, k) = vc(i, k - 1) end if !---meltglac------------------------------------------------- !- includes glaciation effects on HC,HCO ! ------ ice content -------- !print*,"H=",hc (i,k),(1.-p_liq_ice(i,k))*qrco(i,k)*xlf,hc (i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf hc(i, k) = hc(i, k) + (1.-p_liq_ice(i, k))*qrco(i, k)*c_xlf hco(i, k) = hco(i, k) + (1.-p_liq_ice(i, k))*qrco(i, k)*c_xlf end do do k = ktop(i) + 2, ktf hc(i, k) = hes_cup(i, k)!= he_cup(i,k) uc(i, k) = u_cup(i, k) vc(i, k) = v_cup(i, k) hco(i, k) = heso_cup(i, k)!=heo_cup(i,k) zu(i, k) = 0. zuo(i, k) = 0. end do end do !--- Get buoyancy of updrafts call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, hc, he_cup, hes_cup, dby, z_cup) call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, hco, heo_cup, heso_cup, dbyo, zo_cup) if (CONVECTION_TRACER == 1 .and. SGS_W_TIMESCALE == 1 .and. trim(cumulus) == 'deep') then !--- compute vertical velocity ! !call cup_up_vvel(vvel2d,vvel1d,zws,entr_rate_2d,cd,zo,zo_cup,zuo,dbyo,GAMMAo_CUP,tn_cup & ! ,tempco,qco,qrco,qo,start_level,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte& ! ,wlpool,wlpool_bcon,2) wlpool_bcon(:) = wlpool(:) ! !--- trigger function based on KE > CIN if (ADD_COLDPOOL_CLOS == 2) then call cupUpAa0(cin1, zo_cup, zuo, dbyo, gammao_cup, tn_cup, k22, klcl, kbcon, ktop, ierr, itf, ktf, its & , ite, kts, kte, 'CIN') do i = its, itf if (ierr(i) /= 0) cycle ke_mx = 0.5*max(wlpool_bcon(i)**2, zws(i)**2) + 1.e-6 if (ke_mx < abs(min(cin1(i), 0.))) ierr(i) = 500 end do end if end if if (.not. first_guess_w) then !--- calculate in-cloud/updraft air temperature for vertical velocity do i = its, itf if (ierr(i) == 0) then do k = kts, ktf tempco(i, k) = (1./real(c_cp))*(hco(i, k) - c_grav*zo_cup(i, k) - real(c_xlv)*qco(i, k)) end do tempco(i, kte) = tn_cup(i, kte) else tempco(i, :) = tn_cup(i, :) end if end do !--- vertical velocity call cupUpVVel(vvel2d, vvel1d, zws, entr_rate_2d, cd, zo, zo_cup, zuo, dbyo, gammao_cup, tn_cup & , tempco, qco, qrco, qo, start_level, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte, wlpool, wlpool_bcon, 1) end if !---- new rain ! !--- calculate rain mixing ratio in updrafts ! ! call cup_up_rain(cumulus,klcl,kbcon,ktop,k22,ierr,xland & ! ,zo_cup,qco,qrco,pwo,pwavo,po,p_cup,t_cup,tempco& ! ,zuo,up_massentr,up_massdetr,vvel2d,rho & ! ,qrr & ! ,itf,ktf,its,ite, kts,kte) !--- DOWNDRAFT section ! do i = its, itf kzdown(i) = 0 if (ierr(i) .eq. 0) then zktop = (zo_cup(i, ktop(i)) - z1(i))*.6 zktop = min(zktop + z1(i), zcutdown + z1(i)) do k = kts, ktf if (zo_cup(i, k) .gt. zktop) then kzdown(i) = k go to 37 end if end do end if 37 continue end do !--- downdraft originating level - jmin call cupMinimi(heso_cup, k22, kzdown, jmin, ierr, itf, ktf, its, ite, kts, kte) call getJmin(cumulus, itf, ktf, its, ite, kts, kte, ierr, kdet, ktop, kbcon, jmin, ierrc, beta, depth_min, heso_cup, zo_cup & , melting_layer) !--- this calls routine to get downdrafts normalized mass flux do i = its, itf zd(i, :) = 0. if (ierr(i) /= 0) cycle call getZuZdPdf(trim(cumulus), "DOWN", ierr(i), kdet(i), jmin(i), zdo(i, :), kts, kte, ktf, kpbl(i), k22(i), kbcon(i) & , klcl(i), po_cup(i, kts:kte), psur(i), xland(i), random(i)) end do !--- calls routine to get lateral mass fluxes associated with downdrafts call getLateralMassFluxDown(trim(cumulus), itf, ktf, its, ite, kts, kte, ierr, jmin, zo_cup, zdo, xzd, zd, cdd & , mentrd_rate_2d , dd_massentro, dd_massdetro, dd_massentr, dd_massdetr, cumulus, mentrd_rate & , dd_massentru, dd_massdetru, lambau_dn) !--- calls routine to get wet bulb temperature and moisture at jmin if (USE_WETBULB == 1 .and. trim(cumulus) /= 'shallow') then do i = its, itf if (ierr(i) /= 0) cycle k = jmin(i) call getWetbulb(jmin(i), qo_cup(i, k), t_cup(i, k), po_cup(i, k), q_wetbulb(i), t_wetbulb(i)) !print*,"wb =",jmin,qo_cup(i,k),t_cup(i,k),q_wetbulb(i),t_wetbulb(i) !print*,"evap/cool=",q_wetbulb(i)-qo_cup(i,k),t_wetbulb(i)-t_cup(i,k) end do end if !--- downdraft moist static energy + moisture budget do i = its, itf hcdo(i, :) = heso_cup(i, :) ucd(i, :) = u_cup(i, :) vcd(i, :) = v_cup(i, :) dbydo(i, :) = 0. end do do i = its, itf bud(i) = 0. if (ierr(i) /= 0 .or. trim(cumulus) == 'shallow') cycle i_wb = 0 !--for future test if (USE_WETBULB == 1) then !--option 1 !hcdo(i,jmin(i))=cp*t_wetbulb(i)+xlv*q_wetbulb(i)+zo_cup(i,jmin(i))*g !--option 2 hcdo(i, jmin(i)) = 0.5*(real(c_cp)*t_wetbulb(i) + real(c_xlv)*q_wetbulb(i) + zo_cup(i, jmin(i))*c_grav + hc(i, jmin(i))) i_wb = 1 end if dbydo(i, jmin(i)) = hcdo(i, jmin(i)) - heso_cup(i, jmin(i)) bud(i) = dbydo(i, jmin(i))*(zo_cup(i, jmin(i) + 1) - zo_cup(i, jmin(i))) do ki = jmin(i) - i_wb, kts, -1!do ki=jmin(i)-1,1,-1 denom = zdo(i, ki + 1) - 0.5*dd_massdetro(i, ki) + dd_massentro(i, ki) denom_u = zdo(i, ki + 1) - 0.5*dd_massdetru(i, ki) + dd_massentru(i, ki) !-tmp fix for denominator being zero if (denom > 0.0 .and. denom_u > 0.0) then dzo = zo_cup(i, ki + 1) - zo_cup(i, ki) ucd(i, ki) = (ucd(i, ki + 1)*zdo(i, ki + 1) - .5*dd_massdetru(i, ki)*ucd(i, ki + 1) + dd_massentru(i, ki)*us(i, ki) & - p_pgcon*zdo(i, ki + 1)*(us(i, ki + 1) - us(i, ki)))/denom_u vcd(i, ki) = (vcd(i, ki + 1)*zdo(i, ki + 1) - .5*dd_massdetru(i, ki)*vcd(i, ki + 1) + dd_massentru(i, ki)*vs(i, ki) & - p_pgcon*zdo(i, ki + 1)*(vs(i, ki + 1) - vs(i, ki)))/denom_u hcdo(i, ki) = (hcdo(i, ki + 1)*zdo(i, ki + 1) - .5*dd_massdetro(i, ki)*hcdo(i, ki + 1) + dd_massentro(i, ki) & * heo(i, ki))/denom dbydo(i, ki) = hcdo(i, ki) - heso_cup(i, ki) !if(i.eq.ipr)write(0,*)'ki,bud = ',ki,bud(i),hcdo(i,ki) bud(i) = bud(i) + dbydo(i, ki)*dzo else ucd(i, ki) = ucd(i, ki + 1) vcd(i, ki) = vcd(i, ki + 1) hcdo(i, ki) = hcdo(i, ki + 1) end if end do if (bud(i) .gt. 0) then ierr(i) = 7 ierrc(i) = 'downdraft is not negatively buoyant ' end if end do !--- calculate moisture properties of downdraft call cupDdMoisture(cumulus, ierrc, zdo, hcdo, heso_cup, qcdo, qeso_cup, pwdo, qo_cup, zo_cup, dd_massentro, dd_massdetro & , jmin, ierr, gammao_cup, pwevo, bu, qrcdo, qo, heo, tn_cup, 1, t_wetbulb, q_wetbulb, qco, pwavo, itf, ktf & , its, ite, kts, kte) !--test pwevo,bu,qrcdo,qo,heo,t_cup,1,t_wetbulb,q_wetbulb,qco,pwavo, & !--- calculate workfunctions for updrafts call cupUpAa0(aa0, z_cup, zu, dby, GAMMA_CUP, t_cup, k22, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte) call cupUpAa0(aa1, zo_cup, zuo, dbyo, gammao_cup, tn_cup, k22, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte) do i = its, itf if (ierr(i) /= 0) cycle if (aa1(i) .eq. 0.) then ierr(i) = 17 ierrc(i) = "cloud work function zero" end if end do !--- Implements Becker et al (2021) closure, part 1 if ((DICYCLE == 2 .or. DICYCLE == 3) .and. trim(cumulus) == 'deep') then do ki = 1, 2 if (DICYCLE == 2 .and. ki == 2) cycle if (ki == 1) then !-- get the cloud work function for updrafts associated only with RAD + PBL tn_x = t + tn - tn_adv qo_x = q + qo - qo_adv !-- to check => aa1_radpbl=aa1 !! tn_x = tn !! qo_x = qo end if if (ki == 2) then !-- get the cloud work function for updrafts associated only with Qv-advection !tn_x = tn_adv ! orig tn_x = t ! v2 qo_x = qo_adv end if ierr_dummy = ierr call cupEnv(zo, qeso_x, heo_x, heso_x, tn_x, qo_x, po, z1, psur, ierr_dummy, -1, itf, ktf, its, ite, kts, kte) call cupEnvCLev(tn_x, qeso_x, qo_x, heo_x, heso_x, zo, po, qeso_cup_x, qo_cup_x, heo_cup_x, us, vs & , u_cup_x, v_cup_x, heso_cup_x, zo_cup_x, po_cup_x, gammao_CUP_x, tn_cup_x, psur, tsur & , ierr_dummy, z1, itf, ktf, its, ite, kts, kte) !--- get MSE do i = its, itf if (ierr_dummy(i) /= 0) cycle x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) call getCloudBc(cumulus,kts,kte,ktf,xland(i),po(i,kts:kte),heo_cup_x(i,kts:kte),hkbo_x(i),k22(i),x_add & , tpert(i,kts:kte)) hco_x(i, kts:start_level(i)) = hkbo_x(i) do k = start_level(i) + 1, ktop(i) + 1 ! mass cons option denom = (zu(i, k - 1) - .5*up_massdetr(i, k - 1) + up_massentr(i, k - 1)) if (denom > 0.0) then hco_x(i, k) = (hco_x(i, k - 1)*zuo(i, k - 1) - .5*up_massdetro(i, k - 1)*hco_x(i, k - 1) & + up_massentro(i, k - 1)*heo_x(i, k - 1))/denom if (k == start_level(i) + 1) then x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) hco_x(i, k) = hco_x(i, k) + x_add*up_massentro(i, k - 1)/denom end if else hco_x(i, k) = hco_x(i, k - 1) end if !- includes glaciation effects on HCO_X hco_x(i, k) = hco_x(i, k) + (1.-p_liq_ice(i, k))*qrco(i, k)*c_xlf end do hco_x(i, ktop(i) + 2:ktf) = heso_cup_x(i, ktop(i) + 2:ktf) end do call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr_dummy, klcl, kbcon, ktop, hco_x, heo_cup_x, heso_cup_x, dbyo_x & , zo_cup_x) if (ki == 1) then ! RAD+PBL only call cupUpAa0(aa1_radpbl, zo_cup_x, zuo, dbyo_x, gammao_CUP_x, tn_cup_x, k22, klcl, kbcon, ktop, ierr_dummy, itf & , ktf, its, ite, kts, kte) !-- get AA1_ADV !aa1_adv = aa1 + aa0 - aa1_radpbl end if if (ki == 2) & ! ADV of Qv only call cupUpAa0(aa1_adv, zo_cup_x, zuo, dbyo_x, gammao_CUP_x, tn_cup_x, k22, klcl, kbcon, ktop, ierr_dummy, itf, ktf & , its, ite, kts, kte) !Observe that : !aa1 ~ aa0 + (aa1_radpbl-aa0) + (aa1_adv-aa0) end do ! ki end if ! !--- calculate CIN for updrafts ! ! call cup_up_aa0(cin0,z_cup ,zu ,dby ,GAMMA_CUP ,t_cup ,k22,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte,'CIN') ! call cup_up_aa0(cin1,zo_cup,zuo,dbyo ,GAMMAo_CUP ,tn_cup ,k22,klcl,kbcon,ktop,ierr,itf,ktf,its,ite, kts,kte,'CIN') ! !----trigger function for KE+CIN < 0 => no convection ! ! IF( DICYCLE>1) THEN ! do i=its,itf ! if(ierr(i) /= 0) cycle ! print*,"cin=",cin0(i),0.5*zws(i)**2, omeg(i,kpbl(i),1)/(-g*rho(i,kpbl(i))) !call flush(6) ! if(cin0(i) + 0.5*zws(i)**2 < 0.)then !think about including the grid scale vertical velocity at KE calculation ! ierr(i)=19 ! ierrc(i)="CIN negat" ! endif ! enddo ! ENDIF ! ! !--- calculate in-cloud/updraft and downdraft air temperature for vertical velocity ! do i = its, itf if (ierr(i) == 0) then do k = kts, ktf tempcdo(i, k) = (1./real(c_cp))*(hcdo(i, k) - c_grav*zo_cup(i, k) - real(c_xlv)*qcdo(i, k)) end do else tempcdo(i, :) = tn_cup(i, :) end if end do !--- diurnal cycle section !--- Bechtold et al 2008 time-scale of cape removal if (trim(cumulus) == 'deep') then tau_ecmwf(:) = TAU_DEEP; wmean(:) = 3. ! mean vertical velocity m/s else tau_ecmwf(:) = TAU_MID; wmean(:) = 3. end if !--- we shall let all scale dependence on the sig parameter !tau_ecmwf(:)= tau_ecmwf(:) * (1. + 1.66 * (dx(:)/(125*1000.)))! dx must be in meters if (SGS_W_TIMESCALE == 1 .and. trim(cumulus) == 'deep') then do i = its, itf if (ierr(i) /= 0) cycle !- mean vertical velocity based on integration of vertical veloc equation wmean(i) = min(max(vvel1d(i), 3.), 20.) !- time-scale cape removal from Bechtold et al. 2008 tau_ecmwf(i) = (zo_cup(i, ktop(i)) - zo_cup(i, kbcon(i)))/wmean(i) !tau_ecmwf(i)= min(10800., max(720.,tau_ecmwf(i))) tau_ecmwf(i) = min(10800., max(1000., tau_ecmwf(i))) end do !==== ! do i=its,itf ! if(ierr(i) /= 0) cycle ! print*,'tauec',wlpool_bcon(i),vvel1d(i), wmean(i) ,tau_ecmwf(i) ! call flush(6) ! enddo !==== end if !--- Implements the Bechtold et al (2014) and Becker et al (2021) closures do i = its, itf if (ierr(i) /= 0) cycle !- over water ! umean= 2.0+sqrt(0.5*(US(i,1)**2+VS(i,1)**2+US(i,kbcon(i))**2+VS(i,kbcon(i))**2)) ! tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean !- over land ! tau_bl(i) = tau_ecmwf(i) !----------- umean = 2.0 + sqrt(0.5*(us(i, 1)**2 + vs(i, 1)**2 + us(i, kbcon(i))**2 + vs(i, kbcon(i))**2)) !-- - over land - - over ocean s - tau_bl(i) = (1.-xland(i))*tau_ecmwf(i) + xland(i)*(zo_cup(i, kbcon(i)) - z1(i))/umean end do if (DICYCLE <= 3 .and. trim(cumulus) == 'deep') then !-- calculate "pcape" or equivalent cloud work function from the BL forcing only iversion = 0 call cupUpAa1Bl(iversion, aa1_bl, aa1_fa, aa1, t, tn, q, qo, dtime, po_cup, zo_cup, zuo, dbyo, gammao_cup, tn_cup & ,rho, klcl, kpbl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte, xland, ztexec, xlons, xlats & , h_sfc_flux, le_sfc_flux, tau_bl, tau_ecmwf, temp_star, cumulus, tn_bl, qo_bl) do i = its, itf if (ierr(i) /= 0) cycle aa1_bl(i) = (aa1_bl(i)/temp_star)*tau_bl(i) ! units J/kg !aa1_bl(i) = (aa1_bl(i)/T_star) * tau_bl(i) - cin1(i) aa1_bl(i) = min(2000., abs(aa1_bl(i)))*sign(1., aa1_bl(i)) end do !--- Adds Becker et al (2021) closure, part 2 if (DICYCLE == 2) then call getQadv(cumulus, itf, ktf, its, ite, kts, kte, ierr, dtime, q, qo, qo_adv, po, po_cup, qeso, q_adv, col_sat_adv & , alpha_adv, tau_bl, zo_cup, kbcon, ktop) end if if (DICYCLE == 3) then do i = its, itf if (ierr(i) /= 0) cycle aa1_adv(i) = (aa1_adv(i) - aa0(i))*tau_bl(i)/dtime end do end if !--- Implements the Zhang(2002) closure elseif (DICYCLE == 4 .and. trim(cumulus) == 'deep') then !- T and Q profiles modified only by RAD+ADV tendencies do i = its, itf if (ierr(i) /= 0) cycle tn_x(i, kts:ktf) = tn(i, kts:ktf) - tn_bl(i, kts:ktf) + t(i, kts:ktf) qo_x(i, kts:ktf) = qo(i, kts:ktf) - qo_bl(i, kts:ktf) + q(i, kts:ktf) end do !--- calculate moist static energy, heights, qes, ... only by free troposphere tendencies call cupEnv(zo, qeso_x, heo_x, heso_x, tn_x, qo_x, po, z1, psur, ierr, -1, itf, ktf, its, ite, kts, kte) !--- environmental values on cloud levels only by FT tendencies call cupEnvCLev(tn_x, qeso_x, qo_x, heo_x, heso_x, zo, po, qeso_cup_x, qo_cup_x, heo_cup_x, us, vs, u_cup, v_cup, & heso_cup_x, zo_cup, po_cup, gammao_CUP_x, tn_cup_x, psur, tsur, ierr, z1, itf, ktf, its, ite, kts, kte) !--- this is (DT_ve/Dt)_adv+rad do i = its, itf if (ierr(i) /= 0) cycle aa3(i) = 0. do k = max(kbcon(i), kts + 1), ktop(i) dp = -(log(100.*po(i, k)) - log(100.*po(i, k - 1))) !no units aa3(i) = aa3(i) - (tn_cup_x(i, k)*(1.+0.608*qo_cup_x(i, k)) - t_cup(i, k)*(1.+0.608*q_cup(i, k)))*dp/dtime !units = K/s !print*,"tve=",k,aa3(i),tn_cup_x(i,k)*(1.+0.608*qo_cup_x(i,k)),& ! t_cup (i,k)*(1.+0.608*q_cup (i,k)),dp end do end do do i = its, itf if (ierr(i) /= 0) cycle !- this is (DCAPE_env/Dt)_adv+rad !aa1_bl(i) = -aa3(i) !- Zhang threshold: 65 J/kg/hour => 65/(Rd *3600)= 63 10^-6 K/s aa1_bl(i) = aa3(i) - (63.e-6)!*1.5 !print*,"dcape_env=",aa3(i),aa1_bl(i) if (xland(i) > 0.90) aa1_bl(i) = 1.4*aa1_bl(i) !- over water end do !--- this is (DT_ve/Dt)_cu do i = its, itf dtdt(i, :) = 0. dqdt(i, :) = 0. if (ierr(i) /= 0) cycle do k = max(kbcon(i), kts + 1), ktop(i) dp = 100.*(po_cup(i, k + 1) - po_cup(i, k)) rz_env = 0.5*(zuo(i, k + 1) + zuo(i, k) - (zdo(i, k + 1) + zdo(i, k))*edto(i)) s2 = real(c_cp)*tn_cup_x(i, k + 1) + c_grav*zo_cup(i, k + 1) s1 = real(c_cp)*tn_cup_x(i, k) + c_grav*zo_cup(i, k) q2 = qo_cup_x(i, k + 1) q1 = qo_cup_x(i, k) dqdt(i, k) = -rz_env*(q2 - q1)*c_grav/dp dtdt(i, k) = -(1./real(c_cp))*rz_env*(s2 - s1)*c_grav/dp dqdt(i, k) = dqdt(i, k) + (up_massdetro(i, k)*0.5*(qco(i, k + 1) + qco(i, k) - (q2 + q1)) + edto(i) & * dd_massdetro(i, k)*0.5*(qcdo(i, k + 1) + qcdo(i, k) - (q2 + q1)))*c_grav/dp dtdt(i, k) = dtdt(i, k) + (up_massdetro(i, k)*0.5*(tempco(i, k + 1) + tempco(i, k) - (tn_cup_x(i, k + 1) & + tn_cup_x(i, k))) + edto(i)*dd_massdetro(i, k)*0.5*(tempcdo(i, k + 1) + tempcdo(i, k) & - (tn_cup_x(i, k + 1) + tn_cup_x(i, k))))*c_grav/dp !print*,"dtdt=",k, dtdt(i,k),zuo(i,k+1),zdo(i,k+1),dqdt(i,k) end do xk_x(i) = 0. do k = max(kbcon(i), kts + 1), ktop(i) dp = -(log(100.*po_cup(i, k + 1)) - log(100.*po_cup(i, k))) ! no units here xk_x(i) = xk_x(i) + ((1.+0.608*qo_x(i, k))*dtdt(i, k) + 0.608*tn_x(i, k)*dqdt(i, k))*dp ! units=K m/Pa s2 !=> aa3/xk_x will have units of kg/m2/s for the mass flux at cloud base. !print*,"xk_x=",k, xk_x(i),dtdt(i,k),dqdt(i,k) end do end do end if !--- Trigger function based on Xie et al (2019) if (ADV_TRIGGER == 1 .and. trim(cumulus) == 'deep') then daa_adv_dt = 0. do step = 1, 2 !--- calculate moist static energy, heights, qes, ... only by ADV tendencies if (step == 1) then tn_x = t qo_x = q else tn_x = tn_adv qo_x = qo_adv end if call cupEnv(zo, qeso_x, heo_x, heso_x, tn_x, qo_x, po, z1, psur, ierr, -1, itf, ktf, its, ite, kts, kte) call cupEnvCLev(tn_x, qeso_x, qo_x, heo_x, heso_x, zo, po, qeso_cup_x, qo_cup_x, heo_cup_x, us, vs & , u_cup_x, v_cup_x, heso_cup_x, zo_cup_x, po_cup_x, gammao_CUP_x, tn_cup_x, psur, tsur & , ierr, z1, itf, ktf, its, ite, kts, kte) !--- get MSE do i = its, itf if (ierr(i) /= 0) cycle call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), heo_cup_x(i, kts:kte), hkbo_x(i), k22(i)) hco_x(i, kts:start_level(i)) = hkbo_x(i) do k = start_level(i) + 1, ktop(i) + 1 denom = (zuo(i, k - 1) - .5*up_massdetro(i, k - 1) + up_massentro(i, k - 1)) if (denom > 0.0) then hco_x(i, k) = (hco_x(i, k - 1)*zuo(i, k - 1) - .5*up_massdetro(i, k - 1)*hco_x(i, k - 1) & + up_massentro(i, k - 1)*heo_x(i, k - 1))/denom else hco_x(i, k) = hco_x(i, k - 1) end if end do hco_x(i, ktop(i) + 2:ktf) = heso_cup_x(i, ktop(i) + 2:ktf) end do call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, hco_x, heo_cup_x, heso_cup_x, dbyo_x, zo_cup_x) !--- get cloud work function aa_tmp = 0. call cupUpAa0(aa_tmp, zo_cup_x, zuo, dbyo_x, gammao_CUP_x, tn_cup_x, k22, klcl, kbcon, ktop, ierr, itf, ktf, its, ite & , kts, kte) if (step == 1) aa_ini = aa_tmp ! cloud work function initial if (step == 2) aa_adv = aa_tmp ! cloud work function modified by advection tendencies end do ! do i = its, itf if (ierr(i) /= 0) cycle daa_adv_dt(i) = (aa_adv(i) - aa_ini(i))/dtime !print*,"daa_adv_dt J. kg-1 hr-1=",daa_adv_dt(i)*3600. ! call flush(6) if (daa_adv_dt(i) > DCAPE_THRESHOLD/3600. .and. aa_ini(i) > 0.) cycle ! ierr(i) = 90 ierrc(i) = "dcape trigger not satisfied" end do !--- only for output aaa0_(:) = daa_adv_dt(:)*3600. ! J/kg/hour end if !--- determine downdraft strength in terms of windshear call cupDdEdt(cumulus, ierr, us, vs, zo, ktop, kbcon, edt, po, pwavo,pwo, ccn, pwevo, edtmax, edtmin, p_maxens2, edtc, psum & , psumh, rho, p_aeroevap, itf, ktf, ipr, jpr, its, ite, kts, kte, vshear) do iedt = 1, p_maxens2 do i = its, itf if (ierr(i) .eq. 0) then edto(i) = sigd(i)*edtc(i, iedt) edt(i) = edto(i) end if end do !--- get the environmental mass flux do i = its, itf zenv(i, :) = 0.0 if (ierr(i) /= 0) cycle zenv(i, :) = zuo(i, :) - edto(i)*zdo(i, :) end do !--- check mass conservation do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) ! these three are only used at or near mass detrainment and/or entrainment levels entupk = 0. detupk = 0. entdoj = 0. ! detrainment and entrainment for downdrafts detdo = edto(i)*dd_massdetro(i, k) entdo = edto(i)*dd_massentro(i, k) ! entrainment/detrainment for updraft entup = up_massentro(i, k) detup = up_massdetro(i, k) ! subsidence by downdrafts only subin = -zdo(i, k + 1)*edto(i) subdown = -zdo(i, k)*edto(i) if (k .eq. ktop(i)) then detupk = zuo(i, ktop(i)) subin = 0. subdown = 0. detdo = 0. entdo = 0. entup = 0. detup = 0. end if totmas = subin - subdown + detup - entup - entdo + & detdo - entupk - entdoj + detupk + zuo(i, k + 1) - zuo(i, k) if (abs(totmas) .gt. 1.e-6) then write (6, *) '**mass cons: k,ktop,zo(ktop),totmas,subin,subdown,detup,entup,detdo,entdo,entupk,detupk' write (6, 123) 'mass*1.e+6', k, ktop(i), zo(i, ktop(i)), totmas*1.e+6, subin*1.e+6, subdown*1.e+6, detup*1.e+6 & , entup*1.e+6, detdo*1.e+6, entdo*1.e+6, entupk*1.e+6, detupk*1.e+6 123 format(1x, A11, 2i5, 10e12.5) ! call error_fatal ( 'totmas .gt.1.e-6' ) end if end do ! k end do !--- change per unit mass that a model cloud would modify the environment !--- 1. in bottom layer dellu = 0. dellv = 0. dellah = 0. dellat = 0. dellaq = 0. dellaqc = 0. dellabuoy = 0. subten_h = 0. subten_q = 0. subten_t = 0. if (VERT_DISCR == 0) then do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) dellu(i, k) = -(zuo(i, k + 1)*(uc(i, k + 1) - u_cup(i, k + 1)) - zuo(i, k)*(uc(i, k) - u_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(ucd(i, k + 1) - u_cup(i, k + 1)) - zdo(i, k)*(ucd(i, k) - u_cup(i, k)))*c_grav/dp & * edto(i) dellv(i, k) = -(zuo(i, k + 1)*(vc(i, k + 1) - v_cup(i, k + 1)) - zuo(i, k)*(vc(i, k) - v_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(vcd(i, k + 1) - v_cup(i, k + 1)) - zdo(i, k)*(vcd(i, k) - v_cup(i, k)))*c_grav/dp & * edto(i) end do ! k end do do i = its, itf trash = 0.0 trash2 = 0.0 if (ierr(i) .eq. 0) then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) dellah(i, k) = -(zuo(i, k + 1)*(hco(i, k + 1) - heo_cup(i, k + 1)) - zuo(i, k)*(hco(i, k) - heo_cup(i, k))) & * c_grav/dp + (zdo(i, k + 1)*(hcdo(i, k + 1) - heo_cup(i, k + 1)) - zdo(i, k)*(hcdo(i, k) & - heo_cup(i, k)))*c_grav/dp*edto(i) !---meltglac------------------------------------------------- dellah(i, k) = dellah(i, k) + c_xlf*((1.-p_liq_ice(i, k))*0.5*(qrco(i, k + 1) + qrco(i, k)) - melting(i, k)) & * c_grav/dp !-- for output only subten_h(i, k) = -(zuo(i, k + 1)*(-heo_cup(i, k + 1)) - zuo(i, k)*(-heo_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(-heo_cup(i, k + 1)) - zdo(i, k)*(-heo_cup(i, k)))*c_grav/dp*edto(i) !- check H conservation trash2 = trash2 + (dellah(i, k))*dp/c_grav !-- take out cloud liquid/ice water for detrainment detup = up_massdetro(i, k) if (trim(cumulus) == 'mid' .or. trim(cumulus) == 'shallow') then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp elseif (trim(cumulus) == 'deep') then if (.not. use_c1d) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp elseif (C1 > 0.0) then if (k == ktop(i)) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp else dz = zo_cup(i, k + 1) - zo_cup(i, k) dellaqc(i, k) = zuo(i, k)*c1d(i, k)*qrco(i, k)*dz/dp*c_grav end if else if (k == ktop(i)) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp else dz = zo_cup(i, k + 1) - zo_cup(i, k) dellaqc(i, k) = (zuo(i, k)*c1d(i, k)*qrco(i, k)*dz/dp*c_grav + detup*0.5*(qrco(i, k + 1) & + qrco(i, k))*c_grav/dp)*0.5 end if end if end if g_rain = 0.5*(pwo(i, k) + pwo(i, k + 1))*c_grav/dp e_dn = -0.5*(pwdo(i, k) + pwdo(i, k + 1))*c_grav/dp*edto(i) ! pwdo < 0 and E_dn must > 0 !-- condensation source term = detrained + flux divergence of !-- cloud liquid/ice water (qrco) + converted to rain c_up = dellaqc(i, k) + (zuo(i, k + 1)*qrco(i, k + 1) - zuo(i, k)*qrco(i, k))*c_grav/dp + g_rain !-- water vapor budget !-- = flux divergence z*(Q_c - Q_env)_up_and_down & !-- - condensation term + evaporation dellaq(i, k) = -(zuo(i, k + 1)*(qco(i, k + 1) - qo_cup(i, k + 1)) - zuo(i, k)*(qco(i, k) - qo_cup(i, k))) & * c_grav/dp + (zdo(i, k + 1)*(qcdo(i, k + 1) - qo_cup(i, k + 1)) - zdo(i, k)*(qcdo(i, k) & - qo_cup(i, k)))*c_grav/dp*edto(i) - c_up + e_dn !-- for output only subten_q(i, k) = -(zuo(i, k + 1)*(-qo_cup(i, k + 1)) - zuo(i, k)*(-qo_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(-qo_cup(i, k + 1)) - zdo(i, k)*(-qo_cup(i, k)))*c_grav/dp*edto(i) !- check water conservation liq+condensed (including rainfall) trash = trash + (dellaq(i, k) + dellaqc(i, k) + g_rain - e_dn)*dp/c_grav dellabuoy(i, k) = edto(i)*dd_massdetro(i, k)*0.5*(dbydo(i, k + 1) + dbydo(i, k))*c_grav/dp !write(3,*)'=>H= ',k,real(trash2,4),real(dellah(i,k),4) !write(4,*)'=>W= ',k,real(trash,4),real(dellaq(i,k),4) end do ! k !--- test only with double precision: !write(0,*)'=>H/W-FINAL= ',real(trash2,4),real(trash,4),k22(i),kbcon(i),ktop(i) !if(abs(trash)>1.e-6 .or. abs(trash2) > 1.e-6) then ! write(0,*)'=> not water mass or H cons for deep= ',i,trash,trash2 ! !stop 33 !endif end if end do elseif (VERT_DISCR == 1) then !---- convective transport of momentum if (ALP1 == 0.) then !-- fully time explicit do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) dellu(i, k) = -(zuo(i, k + 1)*(uc(i, k + 1) - u_cup(i, k + 1)) - zuo(i, k)*(uc(i, k) - u_cup(i, k))) & * c_grav/dp + (zdo(i, k + 1)*(ucd(i, k + 1) - u_cup(i, k + 1)) - zdo(i, k)*(ucd(i, k) & - u_cup(i, k)))*c_grav/dp*edto(i) dellv(i, k) = -(zuo(i, k + 1)*(vc(i, k + 1) - v_cup(i, k + 1)) - zuo(i, k)*(vc(i, k) - v_cup(i, k))) & * c_grav/dp + (zdo(i, k + 1)*(vcd(i, k + 1) - v_cup(i, k + 1)) - zdo(i, k)*(vcd(i, k) & - v_cup(i, k)))*c_grav/dp*edto(i) end do ! k end do elseif (ALP1 > 0.) then !-- time alp0*explict + ALP1*implicit + upstream alp0 = 1.-ALP1 do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) + 1 fp(k) = 0.5*(zenv(i, k) + abs(zenv(i, k))) fm(k) = 0.5*(zenv(i, k) - abs(zenv(i, k))) end do do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) beta1 = dtime*c_grav/dp aa(k) = ALP1*beta1*fm(k) bb(k) = 1.+ALP1*beta1*(fp(k) - fm(k + 1)) cc(k) = -ALP1*beta1*fp(k + 1) ddu(k) = us(i, k) - (zuo(i, k + 1)*uc(i, k + 1) - zuo(i, k)*uc(i, k))*beta1 + (zdo(i, k + 1)*ucd(i, k + 1) & - zdo(i, k)*ucd(i, k))*beta1*edto(i) ddu(k) = ddu(k) + alp0*beta1*(-fm(k)*us(i, max(kts, k - 1)) + (fm(k + 1) - fp(k))*us(i, k) + fp(k + 1) & * us(i, k + 1)) ddv(k) = vs(i, k) - (zuo(i, k + 1)*vc(i, k + 1) - zuo(i, k)*vc(i, k))*beta1 + (zdo(i, k + 1)*vcd(i, k + 1) & - zdo(i, k)*vcd(i, k))*beta1*edto(i) ddv(k) = ddv(k) + alp0*beta1*(-fm(k)*vs(i, max(kts, k - 1)) + (fm(k + 1) - fp(k))*vs(i, k) + fp(k + 1) & * vs(i, k + 1)) end do call tridiag(ktop(i), aa(kts:ktop(i)), bb(kts:ktop(i)), cc(kts:ktop(i)), ddu(kts:ktop(i))) dellu(i, kts:ktop(i)) = (ddu(kts:ktop(i)) - us(i, kts:ktop(i)))/dtime call tridiag(ktop(i), aa(kts:ktop(i)), bb(kts:ktop(i)), cc(kts:ktop(i)), ddv(kts:ktop(i))) dellv(i, kts:ktop(i)) = (ddv(kts:ktop(i)) - vs(i, kts:ktop(i)))/dtime end do end if !--- convective transport of MSE and Q/Qc !if(USE_FLUX_FORM == 1) then do i = its, itf if (ierr(i) /= 0) cycle !--- moist static energy : flux form + source/sink terms + time explicit ! ! if(use_fct == 0 .or. adjustl(cumulus) == 'shallow') then if (USE_FCT == 0) then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) dellah(i, k) = -(zuo(i, k + 1)*(hco(i, k + 1) - heo_cup(i, k + 1)) - zuo(i, k)*(hco(i, k) - heo_cup(i, k))) & * c_grav/dp + (zdo(i, k + 1)*(hcdo(i, k + 1) - heo_cup(i, k + 1)) - zdo(i, k)*(hcdo(i, k) & - heo_cup(i, k)))*c_grav/dp*edto(i) dellah(i, k) = dellah(i, k) + c_xlf*((1.-p_liq_ice(i, k))* 0.5*(qrco(i, k + 1) + qrco(i, k)) - melting(i, k)) & * c_grav/dp !--- for output only subten_h(i, k) = -(zuo(i, k + 1)*(-heo_cup(i, k + 1)) - zuo(i, k)*(-heo_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(-heo_cup(i, k + 1)) - zdo(i, k)*(-heo_cup(i, k)))*c_grav/dp*edto(i) end do ! k else !-- FCT scheme for the subsidence transport: d(M_env*S_env)/dz sub_tend(1, :) = 0. ! dummy array trcflx_in(1, :) = 0. ! dummy array massflx(i, :) = 0. dtime_max = dtime do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) trcflx_in(1, k) = -(zuo(i, k) - edto(i)*zdo(i, k))*heo_cup(i, k) !* xmb(i) massflx(i, k) = -(zuo(i, k) - edto(i)*zdo(i, k)) !* xmb(i) dtime_max = min(dtime_max, .5*dp) end do call fct1d3(ktop(i), kte, dtime_max, po_cup(i, :), heo(i, :), massflx(i, :), trcflx_in(1, :), sub_tend(1, :)) do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) dellah(i, k) = -(zuo(i, k + 1)*hco(i, k + 1) - zuo(i, k)*hco(i, k))*c_grav/dp + (zdo(i, k + 1)*hcdo(i, k + 1) & - zdo(i, k)*hcdo(i, k))*c_grav/dp*edto(i) dellah(i, k) = dellah(i, k) + c_xlf*((1.-p_liq_ice(i, k))* 0.5*(qrco(i, k + 1) + qrco(i, k)) - melting(i, k)) & * c_grav/dp !- update with subsidence term from the FCT scheme dellah(i, k) = dellah(i, k) + sub_tend(1, k) !--- for output only subten_h(i, k) = sub_tend(1, k) end do ! k end if end do ! elseif(USE_FLUX_FORM == 2) THEN ! ! !- flux form + source/sink terms + time explicit + upstream with anti-diffusion step (Smolarkiewicz 1983) ! alp0=1. ! do i=its,itf ! if(ierr(i) /= 0) cycle ! do istep=1,-1, -2 ! ! if(istep == 1) then ! ddu(:) = heo(i,:) ! do k=kts,ktop(i)+1 ! fp(k) = 0.5*(zenv(i,k)+abs(zenv(i,k))) ! fm(k) = 0.5*(zenv(i,k)-abs(zenv(i,k))) ! enddo ! else ! ddu(kts:ktop(i)+1) = heo(i,kts:ktop(i)+1) + dellah(i,kts:ktop(i)+1)*dtime ! zenv_diff(1,kts) = 0. ! do k=kts,ktop(i)+1 ! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) ! zenv_diff (1,k+1) = 1.06* ( dp*abs(zenv(i,k+1))/g - dtime*zenv(i,k+1)**2 )/dp/g & ! * (ddu(k+1) - ddu(k)) /(ddu(k+1) + ddu(k) + 1.e-16) ! enddo ! do k=kts,ktop(i)+1 ! fp(k) = 0.5*(zenv_diff(1,k)+abs(zenv_diff(1,k))) ! fm(k) = 0.5*(zenv_diff(1,k)-abs(zenv_diff(1,k))) ! enddo ! endif ! do k=kts,ktop(i) ! dp=100.*(po_cup(i,k)-po_cup(i,k+1)) ! beta1 = dtime*g/dp ! ddh(k) = ddu(k) + alp0*beta1*( -fm(k)*ddu(max(kts,k-1)) + (fm(k+1)-fp(k))*ddu(k) + fp(k+1)*ddu(k+1) ) ! enddo ! ! dellah(i,kts:ktop(i)+1)=(ddh(kts:ktop(i)+1)-heo(i,kts:ktop(i)+1))/dtime ! ! enddo ! ! do k=kts,ktop(i) ! dp=100.*(po_cup(i,k)-po_cup(i,k+1)) ! beta1 = g/dp ! ! ddh(k) = -( zuo(i,k+1)*hco (i,k+1) - zuo(i,k)*hco (i,k) )*beta1 & ! +( zdo(i,k+1)*hcdo(i,k+1) - zdo(i,k)*hcdo(i,k) )*beta1*edto(i) ! ! ddh(k) = ddh(k) + xlf*((1.-p_liq_ice(i,k))* & ! 0.5*(qrco(i,k+1)+qrco(i,k)) - melting(i,k))*beta1 ! ! dellah(i,k) = dellah(i,k) + ddh(k) ! ! enddo ! enddo ! endif !------------------------- !--- water vapor + condensates : flux form + source/sink terms + time explicit do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !-- take out cloud liquid/ice water for detrainment detup = up_massdetro(i, k) if (trim(cumulus) == 'mid' .or. trim(cumulus) == 'shallow') then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp elseif (trim(cumulus) == 'deep') then if (.not. use_c1d) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp elseif (C1 > 0.0) then if (k == ktop(i)) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp else dz = zo_cup(i, k + 1) - zo_cup(i, k) dellaqc(i, k) = zuo(i, k)*c1d(i, k)*qrco(i, k)*dz/dp*c_grav end if else if (k == ktop(i)) then dellaqc(i, k) = detup*0.5*(qrco(i, k + 1) + qrco(i, k))*c_grav/dp else dz = zo_cup(i, k + 1) - zo_cup(i, k) dellaqc(i, k) = (zuo(i, k)*c1d(i, k)*qrco(i, k)*dz/dp*c_grav + detup*0.5*(qrco(i, k + 1) + qrco(i, k)) & * c_grav/dp)*0.5 end if end if end if g_rain = 0.5*(pwo(i, k) + pwo(i, k + 1))*c_grav/dp e_dn = -0.5*(pwdo(i, k) + pwdo(i, k + 1))*c_grav/dp*edto(i) ! pwdo < 0 and E_dn must > 0 !-- condensation source term = detrained + flux divergence of !-- cloud liquid/ice water (qrco) + converted to rain c_up = dellaqc(i, k) + (zuo(i, k + 1)*qrco(i, k + 1) - zuo(i, k)*qrco(i, k))*c_grav/dp + g_rain !-- water vapor budget !-- = flux divergence z*(Q_c - Q_env)_up_and_down - condensation term + evaporation dellaq(i, k) = -(zuo(i, k + 1)*qco(i, k + 1) - zuo(i, k)*qco(i, k))*c_grav/dp + (zdo(i, k + 1)*qcdo(i, k + 1) & - zdo(i, k)*qcdo(i, k))*c_grav/dp*edto(i) - c_up + e_dn !--- source of cold pools dellabuoy(i, k) = edto(i)*dd_massdetro(i, k)*0.5*(dbydo(i, k + 1) + dbydo(i, k))*c_grav/dp end do ! if(use_fct == 0 .or. adjustl(cumulus) == 'shallow') then if (USE_FCT == 0) then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) sub_tend(1, k) = -(zuo(i, k + 1)*(-qo_cup(i, k + 1)) - zuo(i, k)*(-qo_cup(i, k)))*c_grav/dp & + (zdo(i, k + 1)*(-qo_cup(i, k + 1)) - zdo(i, k)*(-qo_cup(i, k)))*c_grav/dp*edto(i) end do else !-- FCT scheme for the subsidence transport: d(M_env*S_env)/dz sub_tend(1, :) = 0. ! dummy array trcflx_in(1, :) = 0. ! dummy array massflx(i, :) = 0. dtime_max = dtime do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) trcflx_in(1, k) = -(zuo(i, k) - edto(i)*zdo(i, k))*qo_cup(i, k) !* xmb(i) massflx(i, k) = -(zuo(i, k) - edto(i)*zdo(i, k)) !* xmb(i) dtime_max = min(dtime_max, .5*dp) end do call fct1d3(ktop(i), kte, dtime_max, po_cup(i, :), qo(i, :), massflx(i, :), trcflx_in(1, :), sub_tend(1, :)) end if !--- add the contribuition from the environ subsidence dellaq(i, kts:ktop(i)) = dellaq(i, kts:ktop(i)) + sub_tend(1, kts:ktop(i)) !--- for output only subten_q(i, kts:ktop(i)) = sub_tend(1, kts:ktop(i)) !- check H and water conservation liq+condensed (including rainfall) trash = 0. trash2 = 0.0 do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) g_rain = 0.5*(pwo(i, k) + pwo(i, k + 1))*c_grav/dp e_dn = -0.5*(pwdo(i, k) + pwdo(i, k + 1))*c_grav/dp*edto(i) trash = trash + (dellaq(i, k) + dellaqc(i, k) + g_rain - e_dn)*dp/c_grav trash2 = trash2 + dellah(i, k)*c_grav/dp + c_xlf*((1.-p_liq_ice(i, k))*0.5*(qrco(i, k + 1) + qrco(i, k)) & - melting(i, k))*c_grav/dp end do ! k end do end if ! vertical discretization formulation !--- apply environmental subsidence on grid-scale ice and liq water contents, and cloud fraction (Upwind scheme) if (APPLY_SUB_MP == 1) then dellampqi = 0. dellampql = 0. dellampcf = 0. do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !--- apply environmental subsidence on grid-scale/anvil ice and liq water contents (Upwind scheme) ! env_mf = -0.5*(zenv(i, k + 1) + zenv(i, k)) env_mf_m = min(env_mf, 0.)*c_grav/dp env_mf_p = max(env_mf, 0.)*c_grav/dp dellampqi(:, i, k) = -(env_mf_m*(mpqi(:, i, k + 1) - mpqi(:, i, k)) + env_mf_p*(mpqi(:, i, k) & - mpqi(:, i, max(k - 1, kts)))) dellampql(:, i, k) = -(env_mf_m*(mpql(:, i, k + 1) - mpql(:, i, k)) + env_mf_p*(mpql(:, i, k) & - mpql(:, i, max(k - 1, kts)))) !--- apply environmental subsidence on grid-scale/anvil cloud fraction dellampcf(:, i, k) = -(env_mf_m*(mpcf(:, i, k + 1) - mpcf(:, i, k)) + env_mf_p*(mpcf(:, i, k) & - mpcf(:, i, max(k - 1, kts)))) end do !--- apply environmental subsidence on grid-scale and anvil cloud fraction using time implicit/explict method if (ALP1 > 0.) then alp0 = 1.0 - ALP1 do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) env_mf = -0.5*(zenv(i, k + 1) + zenv(i, k)) env_mf_m = min(env_mf, 0.)*c_grav/dp env_mf_p = max(env_mf, 0.)*c_grav/dp beta1 = -env_mf_m beta2 = -env_mf_p aa(k) = ALP1*beta2 ! coef of f(k-1,t+1), bb(k) = 1.+ALP1*beta1 - ALP1*beta2 ! coef of f(k ,t+1), cc(k) = -ALP1*beta1 ! coef of f(k+1,t+1), !-- this is the rhs of the discretization dd(:, k) = (1.-alp0*beta1 + alp0*beta2)*mpcf(:, i, k) + alp0*beta1*mpcf(:, i, k + 1) - alp0*beta2 & * mpcf(:, i, max(kts, k - 1)) ! coef of f(k-1,t), end do do kmp = 1, nmp !-- this routine solves the problem: aa*f(k-1,t+1) + bb*f(k,t+1) + cc*f(k+1,t+1) = dd call tridiag(ktop(i), aa(kts:ktop(i)), bb(kts:ktop(i)), cc(kts:ktop(i)), dd(kmp, kts:ktop(i))) dellampcf(kmp, i, kts:ktop(i)) = dd(kmp, kts:ktop(i)) - mpcf(kmp, i, kts:ktop(i)) end do end if end do end if !--- make the smoothness procedure if (USE_SMOOTH_TEND > 0) then do i = its, itf if (ierr(i) /= 0) cycle tend2d = 0. do k = kts, ktop(i) rcount = 1.e-8 tend1d = 0. do kk = max(kts, k - USE_SMOOTH_TEND), min(ktop(i), k + USE_SMOOTH_TEND) dp = (po_cup(i, kk) - po_cup(i, kk + 1)) rcount = rcount + dp tend1d(1) = tend1d(1) + dp*dellah(i, kk) tend1d(2) = tend1d(2) + dp*dellaq(i, kk) tend1d(3) = tend1d(3) + dp*dellaqc(i, kk) tend1d(4) = tend1d(4) + dp*dellu(i, kk) tend1d(5) = tend1d(5) + dp*dellv(i, kk) end do tend2d(k, 1:5) = tend1d(1:5)/rcount end do !--- get the final/smoother tendencies do k = kts, ktop(i) dellah(i, k) = tend2d(k, 1) dellaq(i, k) = tend2d(k, 2) dellaqc(i, k) = tend2d(k, 3) dellu(i, k) = tend2d(k, 4) dellv(i, k) = tend2d(k, 5) end do end do end if ! USE_SMOOTH_TEND == 1 !--- using dellas, calculate changed environmental profiles do k = kts, ktf do i = its, itf dellat(i, k) = 0. if (ierr(i) /= 0) cycle ! xhe(i, k) = (dellah(i, k))*mbdt(i) + heo(i, k) xq(i, k) = (dellaq(i, k) + dellaqc(i, k))*mbdt(i) + qo(i, k) if (xq(i, k) .le. 0.) xq(i, k) = 1.e-08 !- do not feed dellat with dellaqc if the detrainment of liquid water !- will be used as a source for cloud microphysics if (p_coupl_mphysics) then dellat(i, k) = (1./real(c_cp))*(dellah(i, k) - real(c_xlv)*dellaq(i, k)) else !---meltglac------------------------------------------------- dellat(i, k) = (1./real(c_cp))*(dellah(i, k) - real(c_xlv)*(dellaq(i, k) + dellaqc(i, k)) & * (1.+(c_xlf/real(c_xlv))*(1.-p_liq_ice(i, k)))) !DELLAT (I,K)=(1./cp)*( DELLAH(I,K) -xlv*(DELLAQ(I,K) + DELLAQC(i,k))) !-adding dellaqc to dellaq: dellaq(i, k) = dellaq(i, k) + dellaqc(i, k) dellaqc(i, k) = 0.0 end if !---meltglac------------------------------------------------- xt(i, k) = ((1./real(c_cp))*dellah(i, k) - (real(c_xlv)/real(c_cp))*(dellaq(i, k) + dellaqc(i, k) & * (1.+(c_xlf/real(c_xlv))*(1.-p_liq_ice(i, k)))))*mbdt(i) + tn(i, k) !XT(I,K)=((1./cp)*DELLAH(i,k)-(xlv/cp)*(DELLAQ(i,k)+DELLAQC(i,k)))*MBDT(i)+TN(I,K) !--- temp tendency due to the environmental subsidence subten_t(i, k) = (1./real(c_cp))*(subten_h(i, k) - real(c_xlv)*subten_q(i, k)) end do end do do i = its, itf if (ierr(i) /= 0) cycle !XHKB(I)=(dsubh(i,k22(i))+DELLAH(I,K22(i)))*MBDT+HKBO(I) xhe(i, ktf) = heo(i, ktf) xq(i, ktf) = qo(i, ktf) xt(i, ktf) = tn(i, ktf) if (xq(i, ktf) .le. 0.) xq(i, ktf) = 1.e-08 end do !- new way for defining XHKB do i = its, itf if (ierr(i) /= 0) cycle !XHKB(I)= DELLAH(I,K22(i))*MBDT+HKBO(I) !-note that HKBO already contains the contribuition from !-ztexec and zqexec call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), dellah(i, kts:kte), dellah_aver, k22(i)) xhkb(i) = dellah_aver*mbdt(i) + hkbo(i) end do !--- calculate moist static energy, heights, qes call cupEnv(xz, xqes, xhe, xhes, xt, xq, po, z1, psur, ierr, -1, itf, ktf, its, ite, kts, kte) !--- environmental values on cloud levels call cupEnvCLev(xt, xqes, xq, xhe, xhes, xz, po, xqes_cup, xq_cup, xhe_cup, us, vs, u_cup, v_cup, xhes_cup, xz_cup & , po_cup, gamma_cup, xt_cup, psur, tsur, ierr, z1, itf, ktf, its, ite, kts, kte) ! !--- static control ! !--- moist static energy inside cloud ! do i = its, itf xhc(i, :) = 0. if (ierr(i) /= 0) cycle do k = kts, start_level(i) !k22(i) xhc(i, k) = xhkb(i) end do end do ! !--- option to produce linear fluxes in the sub-cloud layer. if (trim(cumulus) == 'shallow' .and. USE_LINEAR_SUBCL_MF == 1) then do i = its, itf if (ierr(i) /= 0) cycle call getDelmix(cumulus, kts, kte, ktf, xland(i), start_level(i), po(i, kts:kte), xhe_cup(i, kts:kte) & , xhc(i, kts:kte)) end do end if do i = its, itf if (ierr(i) /= 0) cycle do k = start_level(i) + 1, ktop(i) + 1 ! mass cons option denom = (xzu(i, k - 1) - .5*up_massdetro(i, k - 1) + up_massentro(i, k - 1)) if (denom == 0.0) then xhc(i, k) = xhc(i, k - 1) else xhc(i, k) = (xhc(i, k - 1)*xzu(i, k - 1) - .5*up_massdetro(i, k - 1)*xhc(i, k - 1) + up_massentro(i, k - 1) & * xhe(i, k - 1))/denom if (k == start_level(i) + 1) then x_add = (real(c_xlv)*zqexec(i) + real(c_cp)*ztexec(i)) + x_add_buoy(i) xhc(i, k) = xhc(i, k) + x_add*up_massentro(i, k - 1)/denom end if end if ! !- include glaciation effects on XHC ! ------ ice content -------- xhc(i, k) = xhc(i, k) + c_xlf*(1.-p_liq_ice(i, k))*qrco(i, k) end do do k = ktop(i) + 2, ktf xhc(i, k) = xhes_cup(i, k) xzu(i, k) = 0. end do end do call getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, xhc, xhe_cup, xhes_cup, xdby, xz_cup) ! !--- workfunctions for updraft ! call cupUpAa0(xaa0, xz_cup, xzu, xdby, GAMMA_CUP, xt_cup, k22, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte) do nens = 1, p_maxens do i = its, itf if (ierr(i) /= 0) cycle !~ xaa0_ens(i,nens)=xaa0(i) do k = kts, ktop(i) do nens3 = 1, p_maxens3 if (nens3 .eq. 7) then !--- b=0 pr_ens(i, nens3) = pr_ens(i, nens3) + pwo(i, k) + edto(i)*pwdo(i, k) !--- b=beta else if (nens3 .eq. 8) then pr_ens(i, nens3) = pr_ens(i, nens3) + pwo(i, k) + edto(i)*pwdo(i, k) !--- b=beta/2 else if (nens3 .eq. 9) then pr_ens(i, nens3) = pr_ens(i, nens3) + pwo(i, k) + edto(i)*pwdo(i, k) else pr_ens(i, nens3) = pr_ens(i, nens3) + pwo(i, k) + edto(i)*pwdo(i, k) end if end do end do if (pr_ens(i, 7) .lt. 1.e-6 .and. C0_MID > 0. .and. trim(cumulus) /= 'shallow') then ierr(i) = 18 ierrc(i) = "total normalized condensate too small" do nens3 = 1, p_maxens3 pr_ens(i, nens3) = 0. end do end if do nens3 = 1, p_maxens3 if (pr_ens(i, nens3) < 1.e-5) pr_ens(i, nens3) = 0. end do end do end do ! !--- LARGE SCALE FORCING ! !do i=its,itf ! ierr2(i)=ierr(i) ! ierr3(i)=ierr(i) !enddo ! !--- calculate cloud base mass flux ! if (trim(cumulus) == 'deep') & call cupForcingEns3d(itf, ktf, its, ite, kts, kte, p_ens4, p_ensdim, ichoice, p_maxens, p_maxens2, p_maxens3 & , ierr, ierr2, ierr3, k22, kbcon, ktop, xland1, aa0, aa1, xaa0, mbdt, dtime & , xf_ens, mconv, qo, po_cup, omeg, zdo, zuo, pr_ens, edto, tau_ecmwf, aa1_bl, xf_dicycle & , xk_x, alpha_adv, q_adv, aa1_radpbl, aa1_adv, wlpool_bcon, xf_coldpool) if (trim(cumulus) == 'mid') & call cupForcingEns3dMid(aa0, aa1, xaa0, mbdt, dtime, ierr, po_cup, ktop, k22, kbcon, kpbl, ichoice, p_maxens & , p_maxens3, itf, ktf, its, ite, kts, kte, tau_ecmwf, aa1_bl, xf_dicycle, dhdt, xff_mid, zws, hc & , hco, he_cup, heo_cup, wlpool_bcon, xf_coldpool) if (trim(cumulus) == 'shallow') then call cupUpCape(cape, z, zu, dby, gamma_cup, t_cup, k22, kbcon, ktop, ierr, tempco, qco, qrco, qo_cup, itf, ktf, its & , ite, kts, kte) call cupForcingEns3dShal(itf, ktf, its, ite, kts, kte, dtime, ichoice, ierrc, ierr, klcl, kpbl, kbcon, k22, ktop & , xmb, tsur, cape, h_sfc_flux, le_sfc_flux, zws, po, hco, heo_cup, po_cup, t_cup, dhdt & , rho, xff_shal, xf_dicycle, tke_pbl, wlpool_bcon, xf_coldpool) end if ! ! !--- get the net precipitation at surface ! do i = its, itf if (ierr(i) == 0) then pwo_eff(i, :) = pwo(i, :) + edto(i)*pwdo(i, :) else pwo_eff(i, :) = 0. end if end do end do !--- Include kinetic energy dissipation converted to heating call keToHeating(itf, ktf, its, ite, kts, kte, ktop, ierr, po_cup, us, vs, dellu, dellv, dellat) !--- feedback call cupOutputEns3d(cumulus, xff_shal, xff_mid, xf_ens, ierr, dellat, dellaq, dellaqc, outt, outq, outqc, zuo, pre, pwo_eff & , xmb, ktop, p_maxens2, p_maxens, ierr2, ierr3, pr_ens, p_maxens3, p_ensdim, sig, xland1, ichoice, ipr & , jpr, itf, ktf, its, ite, kts, kte, xf_dicycle, outu, outv, dellu, dellv, dtime, po_cup, kbcon, dellabuoy & , outbuoy, dellampqi, outmpqi, dellampql, outmpql, dellampcf, outmpcf, nmp, rh_dicycle_fct, xf_coldpool & , wlpool_bcon) !--- get the net precipitation flux (after downdraft evaporation) call getPrecipFluxes(cumulus, klcl, kbcon, ktop, k22, ierr, xland, pre, xmb, pwo, pwavo, edto, pwevo, pwdo, t_cup, tempco & , prec_flx, evap_flx, itf, ktf, its, ite, kts, kte) !--- rainfall evap below cloud base if (USE_REBCB == 1) & call rainEvapBelowCloudBase(cumulus, itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, xmb, psur, xland, qo_cup, t_cup & , po_cup, qes_cup, pwavo, edto, pwevo, pwo, pwdo, pre, prec_flx, evap_flx, outt, outq & , outbuoy, evap_bcb) !--- includes effects of the remained cloud dissipation into the enviroment if (USE_CLOUD_DISSIPATION >= 0.) & call cloudDissipation(cumulus, itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, dtime, xmb, xland, qo_cup, qeso_cup & , po_cup, outt, outq, outqc, zuo, vvel2d, rho_hydr, qrco, sig, tempco, qco, tn_cup, heso_cup, zo) !--- get the total (deep+congestus) evaporation flux for output (units kg/kg/s) do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !--- add congestus and deep plumes, and convert to kg/kg/s revsu_gf(i, k) = revsu_gf(i, k) + evap_flx(i, k)*c_grav/dp end do end do !--- get lightning flashes density (parameterization from Lopez 2016, MWR) if (LIGHTNING_DIAG == 1 .and. trim(cumulus) == 'deep') then call cupUpCape(cape, z, zu, dby, gamma_cup, t_cup, k22, kbcon, ktop, ierr, tempco, qco, qrco, qo_cup, itf, ktf, its, ite & , kts, kte) call cupUpLightning(itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, xland, cape, zo, zo_cup, t_cup, t, tempco, qrco & , po_cup, rho, prec_flx, lightn_dens) end if !--- for outputs (only deep plume) if (trim(cumulus) == 'deep') then do i = its, itf if (ierr(i) /= 0) cycle var2d(i) = p_cwv_ave(i) do k = kts, ktop(i) + 1 prfil_gf(i, k) = prec_flx(i, k) var3d_agf(i, k) = vvel2d(i, k) end do end do end if !--- for tracer convective transport / outputs do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktf !clwup5d (i,k) = qrco (i,k) !ice/liquid water !tup (i,k) = (1./cp)*(hco(i,k)-g*zo_cup(i,k)-xlv*qco(i,k))!in-updraft temp tup(i, k) = tempco(i, k) !in-updraft temp end do tup(i, kte) = t_cup(i, kte) end do !--- convert mass fluxes, etc... do i = its, itf if (ierr(i) /= 0) cycle pwavo(i) = xmb(i)*pwavo(i) pwevo(i) = xmb(i)*pwevo(i) zuo(i, :) = xmb(i)*zuo(i, :) zdo(i, :) = xmb(i)*zdo(i, :) pwo(i, :) = xmb(i)*pwo(i, :) pwdo(i, :) = xmb(i)*pwdo(i, :) up_massentro(i, :) = xmb(i)*up_massentro(i, :) up_massdetro(i, :) = xmb(i)*up_massdetro(i, :) dd_massentro(i, :) = xmb(i)*dd_massentro(i, :) dd_massdetro(i, :) = xmb(i)*dd_massdetro(i, :) zenv(i, :) = xmb(i)*zenv(i, :) end do !--for output only. do i = its, itf subten_q(i, :) = xmb(i)*subten_q(i, :) subten_h(i, :) = xmb(i)*subten_h(i, :) subten_t(i, :) = xmb(i)*subten_t(i, :) end do !--- outputs a model sounding for the stand-alone code (part 2) if (output_sound == 1) then call sound(2, cumulus, int_time, dtime, p_ens4, itf, ktf, its, ite, kts, kte, xlats, xlons, jcol, whoami_all & , z, qes, he, hes, t, q, po, z1, psur, zo, qeso, heo, heso, tn, qo, us, vs, omeg, xz & , h_sfc_flux, le_sfc_flux, tsur, dx, stochastic_sig, zws, ztexec, zqexec, xland & , kpbl, k22, klcl, kbcon, ktop, aa0, aa1, sig, xaa0, hkb, xmb, pre, edto & , zo_cup, dhdt, rho, zuo, zdo, up_massentro, up_massdetro, outt, outq, outqc, outu, outv) end if !--- for output only if (trim(cumulus) == 'deep') then aa1_(:) = aa1(:) aaa0_(:) = aa0(:) aa1_radpbl_(:) = aa1_radpbl(:) if (DICYCLE == 2) then aa1_adv_(:) = q_adv(:) else ! AA1_ADV_ (:) = AA1_ADV (:) ! AA1_ADV_ (:) = wlpool_bcon(:) aa1_adv_(:) = vshear(:) ! AA1_ADV_ (:) = depth_neg_buoy (:) ! AA1_ADV_ (:) = cin1 (:) end if do i = its, itf if (ierr(i) == 0) cycle kbcon(i) = 1 ktop(i) = 1 klcl(i) = 1 jmin(i) = 1 k22(i) = 1 end do end if if (LIQ_ICE_NUMBER_CONC == 1) then call getLiqIceNumberConc(itf, ktf, its, ite, kts, kte, ierr, ktop, dtime, rho, outqc, tempco, outnliq, outnice) end if !- section for atmospheric composition if (USE_TRACER_TRANSP == 1) then !--only for debug if (p_use_gate) then if (jl == 1) then se_chem_update(1, :, :) = se_chem(1, :, :) else se_chem(1, :, :) = se_chem_update(1, :, :) end if do i = its, itf if (ierr(i) /= 0) cycle massi = 0. do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) massi = massi + se_chem(1, i, k)*dp/c_grav end do end do end if !--only for debug !-1) get mass mixing ratios at the cloud levels call cupEnvClevChem(mtp, se_chem, se_cup_chem, ierr, itf, ktf, its, ite, kts, kte) !-2) determine in-cloud tracer mixing ratios ! ! a) chem - updraft !- note: here "sc_up_chem" stores the total in-cloud tracer mixing ratio (i.e., including the portion ! embedded in the condensates). call getInCloudScChemUp(cumulus, fscav, mtp, se_chem, se_cup_chem, sc_up_chem, pw_up_chem, tot_pw_up_chem, zo_cup, rho & , po, po_cup, qrco, tempco, pwo, zuo, up_massentro, up_massdetro, vvel2d, vvel1d, start_level, k22 & , kbcon, ktop, klcl, ierr, xland, itf, ktf, its, ite, kts, kte) ! b) chem - downdraft call getInCloudScChemDd(cumulus, fscav, mtp, se_chem, se_cup_chem, sc_dn_chem, pw_dn_chem, pw_up_chem, sc_up_chem & , tot_pw_up_chem, tot_pw_dn_chem, zo_cup, rho, po_cup, qrcdo, pwdo, pwevo, edto, zdo, dd_massentro & , dd_massdetro, pwavo, pwo, jmin, ierr, itf, ktf, its, ite, kts, kte) ! !-3) determine the vertical transport including mixing, scavenging and evaporation ! !---a) change per unit mass that a model cloud would modify the environment do i = its, itf if (ierr(i) /= 0) cycle !- flux form + source/sink terms + time explicit + FCT if (USE_FLUX_FORM == 1 .and. ALP1 == 0.) then if (USE_FCT == 0) then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) out_chem(:, i, k) = -(zuo(i, k + 1)*(sc_up_chem(:, i, k + 1) - se_cup_chem(:, i, k + 1)) - zuo(i, k) & * (sc_up_chem(:, i, k) - se_cup_chem(:, i, k)))*c_grav/dp + (zdo(i, k + 1) & * (sc_dn_chem(:, i, k + 1) - se_cup_chem(:, i, k + 1)) - zdo(i, k)*(sc_dn_chem(:, i, k) & - se_cup_chem(:, i, k)))*c_grav/dp*edto(i) end do else !-- FCT scheme for the subsidence transport: d(M_env*S_env)/dz sub_tend = 0. trcflx_in = 0. dtime_max = dtime massflx(i, :) = 0. do k = kts + 1, ktop(i) + 1 dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) trcflx_in(:, k) = -(zuo(i, k) - edto(i)*zdo(i, k))*se_cup_chem(:, i, k) !* xmb(i) massflx(i, k) = -(zuo(i, k) - edto(i)*zdo(i, k)) !* xmb(i) dtime_max = min(dtime_max, .5*dp) end do !- if dtime_max<dtime => needs a loop to update from t to t+dtime (check this!) !if( dtime_max < dtime ) stop "dtime_max < dtime in GF scheme" do ispc = 1, mtp call fct1d3(ktop(i), kte, dtime_max, po_cup(i, :), se_chem(ispc, i, :), massflx(i, :), trcflx_in(ispc, :) & , sub_tend(ispc, :)) end do do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) out_chem(:, i, k) = -(zuo(i, k + 1)*(sc_up_chem(:, i, k + 1)) - zuo(i, k)*(sc_up_chem(:, i, k)))*c_grav/dp & + (zdo(i, k + 1)*(sc_dn_chem(:, i, k + 1)) - zdo(i, k)*(sc_dn_chem(:, i, k))) *c_grav/dp & * edto(i) !- update with the subsidence term from FCT scheme out_chem(:, i, k) = out_chem(:, i, k) + sub_tend(:, k) end do end if !- include evaporation (this term must not be applied to the tracer 'QW') if (USE_TRACER_EVAP == 1 .and. trim(cumulus) /= 'shallow') then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) out_chem(:,i,k) = out_chem(:,i,k) - 0.5*edto(i)*(zdo(i,k)*pw_dn_chem(:,i,k)+zdo(i,k+1) * pw_dn_chem(:,i,k+1)) & * c_grav/dp !& ! evaporated ( pw_dn < 0 => E_dn > 0) !*chem_name_mask_evap(:) !-- to avoid the "Dry Mass Violation" end do end if !- include scavenging if (USE_TRACER_SCAVEN > 0 .and. trim(cumulus) /= 'shallow') then do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) out_chem(:, i, k) = out_chem(:, i, k) - 0.5*(zuo(i, k)*pw_up_chem(:, i, k) + zuo(i, k + 1) & * pw_up_chem(:, i, k + 1))*c_grav/dp ! incorporated in rainfall (<0) end do end if end if ! IF(USE_FLUX_FORM == 1 .and. ALP1 == 0. ) !- flux form + source/sink terms + time explicit/implicit + upstream if (USE_FLUX_FORM == 1 .and. ALP1 > 0.) then alp0 = 1.-ALP1 do k = kts, ktop(i) + 1 fp(k) = 0.5*(zenv(i, k) + abs(zenv(i, k))) fm(k) = 0.5*(zenv(i, k) - abs(zenv(i, k))) end do do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) beta1 = dtime*c_grav/dp aa(k) = ALP1*beta1*fm(k) bb(k) = 1.+ALP1*beta1*(fp(k) - fm(k + 1)) cc(k) = -ALP1*beta1*fp(k + 1) ddtr(:, k) = se_chem(:, i, k) - (zuo(i, k + 1)*sc_up_chem(:, i, k + 1) - zuo(i, k)*sc_up_chem(:, i, k))*beta1 & + (zdo(i, k + 1)*sc_dn_chem(:, i, k + 1) - zdo(i, k)*sc_dn_chem(:, i, k))*beta1*edto(i) !- include evaporation (this term must not be applied to the tracer 'QW') if (USE_TRACER_EVAP == 1 .and. trim(cumulus) /= 'shallow') then out_chem(:,i,k) = out_chem(:,i,k) - 0.5*edto(i)*(zdo(i,k)*pw_dn_chem(:,i,k)+zdo(i,k+1) * pw_dn_chem(:,i,k+1)) & * beta1 !& ! evaporated ( pw_dn < 0 => E_dn > 0) !*chem_name_mask_evap(:) !-- to avoid the "Dry Mass Violation" end if !- include scavenging if (USE_TRACER_SCAVEN > 0 .and. trim(cumulus) /= 'shallow') then out_chem(:, i, k) = out_chem(:, i, k) - 0.5*(zuo(i, k)*pw_up_chem(:, i, k) + zuo(i, k + 1) & * pw_up_chem(:, i, k + 1))*beta1 ! incorporated in rainfall (<0) end if ddtr(:, k) = ddtr(:, k) + out_chem(:, i, k) + alp0*beta1*(-fm(k)*se_chem(:, i, max(kts, k - 1)) + (fm(k + 1) & - fp(k))*se_chem(:, i, k) + fp(k + 1)*se_chem(:, i, k + 1)) end do do ispc = 1, mtp if (chem_name_mask(ispc) == 0) cycle call tridiag(ktop(i), aa(kts:ktop(i)), bb(kts:ktop(i)), cc(kts:ktop(i)), ddtr(ispc, kts:ktop(i))) out_chem(ispc, i, kts:ktop(i)) = (ddtr(ispc, kts:ktop(i)) - se_chem(ispc, i, kts:ktop(i)))/dtime end do end if !USE_FLUX_FORM == 1 .and. ALP1 > 0. !- flux form + source/sink terms + time explicit + upstream with anti-diffusion step (Smolarkiewicz 1983) if (USE_FLUX_FORM == 2 .or. USE_FLUX_FORM == 3) then if (USE_FLUX_FORM == 2) lstep = -1 ! upstream + anti-diffusion step if (USE_FLUX_FORM == 3) lstep = 1 ! only upstream alp0 = 1. if (ierr(i) /= 0) cycle !--- Zenv here have the following reference: < 0 => downward motion zenv(i, :) = -(zuo(i, :) - edto(i)*zdo(i, :)) do istep = 1, lstep, -2 if (istep == 1) then ddtr_upd(:, :) = se_chem(:, i, :) do k = kts, ktop(i) + 1 fp_mtp(:, k) = 0.5*(zenv(i, k) + abs(zenv(i, k))) fm_mtp(:, k) = 0.5*(zenv(i, k) - abs(zenv(i, k))) end do else ddtr_upd(:, kts:ktop(i) + 1) = se_chem(:, i, kts:ktop(i) + 1) + out_chem(:, i, kts:ktop(i) + 1)*dtime zenv_diff(:, kts) = 0. do k = kts, ktop(i) + 1 dz = zo_cup(i, k + 1) - zo_cup(i, k) zenv_diff(:, k + 1) = 1.08*(dz*abs(zenv(i, k + 1)) - dtime*zenv(i, k + 1)**2) & *(ddtr_upd(:, k + 1) - ddtr_upd(:, k)) & /((ddtr_upd(:, k + 1) + ddtr_upd(:, k) + 1.e-16)*dz) end do do k = kts, ktop(i) + 1 fp_mtp(:, k) = 0.5*(zenv_diff(:, k) + abs(zenv_diff(:, k))) fm_mtp(:, k) = 0.5*(zenv_diff(:, k) - abs(zenv_diff(:, k))) end do end if do k = kts, ktop(i) dp = -100.*(po_cup(i, k) - po_cup(i, k + 1)) beta1 = dtime*c_grav/dp ddtr(:, k) = ddtr_upd(:, k) + alp0*beta1*((fp_mtp(:, k + 1)*ddtr_upd(:, k) + fm_mtp(:, k + 1) & * ddtr_upd(:, k + 1)) - (fp_mtp(:, k)*ddtr_upd(:, max(kts, k - 1)) + fm_mtp(:, k)*ddtr_upd(:, k))) end do do ispc = 1, mtp if (chem_name_mask(ispc) == 0) cycle out_chem(ispc, i, kts:ktop(i)) = (ddtr(ispc, kts:ktop(i)) - se_chem(ispc, i, kts:ktop(i)))/dtime end do end do ! anti-diff steps do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) beta1 = c_grav/dp out_chem(:, i, k) = out_chem(:, i, k) - (zuo(i, k + 1)*sc_up_chem(:, i, k + 1) - zuo(i, k)*sc_up_chem(:, i, k)) & * beta1 + (zdo(i, k + 1)*sc_dn_chem(:, i, k + 1) - zdo(i, k)*sc_dn_chem(:, i, k))*beta1*edto(i) !- include evaporation (this term must not be applied to the tracer 'QW') if (USE_TRACER_EVAP == 1 .and. trim(cumulus) /= 'shallow') then out_chem(:,i,k) = out_chem(:,i,k) - 0.5*edto(i)*(zdo(i,k)*pw_dn_chem(:,i,k)+zdo(i,k+1) * pw_dn_chem(:,i,k+1)) & * beta1 !& ! evaporated ( pw_dn < 0 => E_dn > 0) !*chem_name_mask_evap(:) !-- to avoid the "Dry Mass Violation" end if !- include scavenging if (USE_TRACER_SCAVEN > 0 .and. trim(cumulus) /= 'shallow') then out_chem(:, i, k) = out_chem(:, i, k) - 0.5*(zuo(i, k)*pw_up_chem(:, i, k) + zuo(i, k + 1) & * pw_up_chem(:, i, k + 1))*beta1 ! incorporated in rainfall (<0) end if end do end if ! USE_FLUX_FORM == 2 .or. USE_FLUX_FORM == 3 !--- check mass conservation for tracers do ispc = 1, mtp if (chem_name_mask(ispc) == 0) cycle trash_(:) = 0. trash2_(:) = 0. evap_(:) = 0. wetdep_(:) = 0. residu_(:) = 0. do k = kts, ktop(i) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) evap = -0.5*(zdo(i, k)*pw_dn_chem(ispc, i, k) + zdo(i, k + 1)*pw_dn_chem(ispc, i, k + 1))*c_grav/dp*edto(i) wetdep = 0.5*(zuo(i, k)*pw_up_chem(ispc, i, k) + zuo(i, k + 1)*pw_up_chem(ispc, i, k + 1))*c_grav/dp evap_(ispc) = evap_(ispc) + evap*dp/c_grav wetdep_(ispc) = wetdep_(ispc) + wetdep*dp/c_grav residu_(ispc) = residu_(ispc) + (wetdep - evap)*dp/c_grav !trash_ (ispc) = trash_ (ispc) + (out_chem (ispc,i,k) - evap + wetdep)*dp/g trash_(ispc) = trash_(ispc) + (out_chem(ispc, i, k))*dp/c_grav trash2_(ispc) = trash2_(ispc) + se_chem(ispc, i, k)*dp/c_grav end do if (residu_(ispc) < 0.) then beta1 = c_grav/(po_cup(i, kts) - po_cup(i, ktop(i) + 1)) do k = kts, ktop(i) out_chem(ispc, i, k) = out_chem(ispc, i, k) + residu_(ispc)*beta1 end do end if !if(evap_ (ispc) > wetdep_(ispc)) then !print*,"budget=",ispc,evap_ (ispc), wetdep_(ispc),trash_ (ispc),trim(CHEM_NAME(ispc))!,trash_ (ispc),trash2_(ispc) !call flush(6) !endif !if(evap_ (ispc) > wetdep_(ispc)) stop " eva<wet " !if(abs(trash_(ispc)) >1.e-6 ) then ! if (MAPL_AM_I_ROOT()) write(6,*)'=> mass_cons=',trash_(ispc),spacing(trash2_(ispc)),trim(CHEM_NAME(ispc)),trim(cumulus) !endif end do end do ! loop 'i' if (p_use_gate) then !--only for debug do i = its, itf if (ierr(i) /= 0) cycle massf = 0. do k = kts, ktop(i) se_chem_update(ispc_co, i, k) = se_chem_update(ispc_co, i, k) + out_chem(ispc_co, i, k)*dtime !se_chem_update(ispc_CO,i,k) = max(0.,se_chem_update(ispc_CO,i,k)) dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) evap_(ispc_co) = -0.5*(zdo(i, k)*pw_dn_chem(ispc_co, i, k) + zdo(i, k + 1)*pw_dn_chem(ispc_co, i, k + 1)) & * c_grav/dp*edto(i) wetdep_(ispc_co) = 0.5*(zuo(i, k)*pw_up_chem(ispc_co, i, k) + zuo(i, k + 1)*pw_up_chem(ispc_co, i, k + 1)) & * c_grav/dp massf = massf + se_chem_update(1, i, k)*dp/c_grav + (-evap_(ispc_co) + wetdep_(ispc_co))*dp/c_grav end do if (abs((massf - massi)/(1.e-12 + massi)) > 1.e-6) print *, "mass con=>", (massf - massi)/(1.e-12 + massi) end do 19 format(1x, I3, 1x, 5e14.3) 18 format(1x, I3, 1x, 4e14.3) 20 format(1x, I3, 1x, 11e16.6) !--only for debug end if end if !- end of section for atmospheric composition !--------------------------------------------------------------------------------------------! ! !IF(use_gate) THEN ! do i=its,itf ! massf = 0. ! if(ierr(i) /= 0) cycle ! do k=kts,ktop(i) ! se_chem_update(1,i,k) = se_chem_update(1,i,k) + outmpql(lsmp,i,k)* dtime ! se_chem_update(2,i,k) = se_chem_update(2,i,k) + outmpqi(lsmp,i,k)* dtime ! se_chem_update(3,i,k) = se_chem_update(3,i,k) + outmpcf(lsmp,i,k)* dtime ! mpql (lsmp,i,k) = se_chem_update(1,i,k) ! mpqi (lsmp,i,k) = se_chem_update(2,i,k) ! mpcf (lsmp,i,k) = se_chem_update(3,i,k) ! enddo ! enddo !ENDIF !- for debug/diag if (trim(cumulus) == 'deep') then do i = its, itf !if(ierr(i) /= 0) cycle aaa0_(i) = aa0(i) aa1_(i) = aa1(i) aa1_bl_(i) = aa1_bl(i) tau_bl_(i) = tau_bl(i) tau_ec_(i) = tau_ecmwf(i) ! if(USE_MEMORY == 0) tau_ec_ (i) = x_add_buoy(i) end do end if !- begin: for GATE soundings------------------------------------------- if (p_use_gate .or. wrtgrads) then if (trim(cumulus) == 'deep') then cty = '1' nvarbegin = 0 end if if (trim(cumulus) == 'shallow') then cty = '2' nvarbegin = 101 end if if (trim(cumulus) == 'mid') then cty = '3' nvarbegin = 201 end if do i = its, itf !if(ierr(i).eq.0) then !- 2-d section do k = kts, ktf !max(1,ktop(i)) nvar = nvarbegin if (trim(cumulus) == 'deep') & call setGradsVar(jl, k, nvar, zo(i, k), "zo"//cty, ' height', '3d') ! call set_grads_var(jl,k,nvar,po(i,k),"po"//cty ,' press','3d') dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) e_dn = -0.5*(pwdo(i, k) + pwdo(i, k + 1))*c_grav/dp*edto(i)*86400.*real(c_xlv)/real(c_cp)*xmb(i) ! pwdo < 0 and E_dn must > 0 c_up = dellaqc(i, k) + (zuo(i, k + 1)*qrco(i, k + 1) - zuo(i, k)*qrco(i, k))*c_grav/dp + 0.5*(pwo(i, k) & + pwo(i, k + 1))*c_grav/dp c_up = -c_up*86400.*real(c_xlv)/real(c_cp)*xmb(i) trash = -(zuo(i, k + 1)*(qco(i, k + 1) - qo_cup(i, k + 1)) - zuo(i, k)*(qco(i, k) - qo_cup(i, k)))*c_grav/dp trash2 = +(zdo(i, k + 1)*(qcdo(i, k + 1) - qo_cup(i, k + 1)) - zdo(i, k)*(qcdo(i, k) - qo_cup(i, k)))*c_grav/dp & * edto(i) trash = trash*86400.*real(c_xlv)/real(c_cp)*xmb(i) trash2 = trash2*86400.*real(c_xlv)/real(c_cp)*xmb(i) env_mf = 0.5*((zuo(i, k + 1) - zdo(i, k + 1)*edto(i)) + (zuo(i, k) - zdo(i, k)*edto(i))) resten_h = dellah(i, k) - subten_h(i, k) resten_q = dellaq(i, k) - subten_q(i, k) resten_t = (1./real(c_cp))*(resten_h - real(c_xlv)*resten_q) !trash2 = qco (i,k )! zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) !*g/dp !trash = qo_cup(i,k )! zuo(i,k )*(qco (i,k )-qo_cup(i,k ) ) !*g/dp trash2 = zuo(i, k + 1)*(qco(i, k + 1) - qo_cup(i, k + 1))*1000 !*g/dp trash = zuo(i, k)*(qco(i, k) - qo_cup(i, k))*1000 !*g/dp call setGradsVar(jl, k, nvar, out_chem(1, i, k)*86400, "outchem"//cty, ' outchem', '3d') call setGradsVar(jl, k, nvar, sc_up_chem(1, i, k), "scup"//cty, ' sc_chem', '3d') call setGradsVar(jl, k, nvar, sc_dn_chem(1, i, k), "scdn"//cty, ' sc_chem', '3d') call setGradsVar(jl, k, nvar, massi, "mi"//cty, ' initial mass', '2d') call setGradsVar(jl, k, nvar, massf, "mf"//cty, ' final mass', '2d') call setGradsVar(jl, k, nvar, se_chem(1, i, k), "se"//cty, ' se_chem', '3d') call setGradsVar(jl, k, nvar, se_cup_chem(1, i, k), "secup"//cty, ' se_cup_chem', '3d') !-- only for debug !call set_grads_var(jl,k,nvar,se_chem_update(1,i,k),"newse"//cty ,' new se_chem','3d') if (APPLY_SUB_MP == 1) then kmp = p_lsmp call setGradsVar(jl, k, nvar, outmpqi(kmp, i, k)*86400*1000, "outqi"//cty, ' outmpqi', '3d') call setGradsVar(jl, k, nvar, outmpql(kmp, i, k)*86400*1000, "outql"//cty, ' outmpql', '3d') call setGradsVar(jl, k, nvar, outmpcf(kmp, i, k)*86400, "outcf"//cty, ' outmpcf', '3d') call setGradsVar(jl, k, nvar, mpqi(kmp, i, k), "mpqi"//cty, ' mpqi', '3d') call setGradsVar(jl, k, nvar, mpql(kmp, i, k), "mpql"//cty, ' mpql', '3d') call setGradsVar(jl, k, nvar, mpcf(kmp, i, k), "mpcf"//cty, ' mpcf', '3d') end if call setGradsVar(jl, k, nvar, env_mf, "sub"//cty, ' sub', '3d') if (LIQ_ICE_NUMBER_CONC == 1) then call setGradsVar(jl, k, nvar, outnice(i, k)*86400., "outnice"//cty, 'out # ice1/day', '3d') call setGradsVar(jl, k, nvar, outnliq(i, k)*86400., "outnliq"//cty, 'out # liq /day', '3d') end if call setGradsVar(jl, k, nvar, zuo(i, k)/xmb(i), "zup"//cty, 'norm m flux up ', '3d') call setGradsVar(jl, k, nvar, zdo(i, k)/xmb(i), "zdn"//cty, 'norm m flux dn ', '3d') call setGradsVar(jl, k, nvar, zenv(i, k), "zenv"//cty, 'norm m flux env ', '3d') call setGradsVar(jl, k, nvar, -edto(i)*xmb(i)*zdo(i, k), "mdn"//cty, 'm flux down (kg/s/m^2)', '3d') call setGradsVar(jl, k, nvar, up_massentro(i, k), "upent"//cty, 'up_massentr(kg/s/m^2)', '3d') call setGradsVar(jl, k, nvar, xmb(i)*up_massdetro(i, k), "updet"//cty, 'up_massdetr(kg/s/m^2)', '3d') call setGradsVar(jl, k, nvar, outt(i, k)*86400., "outt"//cty, 'outt K/day', '3d') call setGradsVar(jl, k, nvar, resten_t*86400., "rest"//cty, 'residuo T K/day', '3d') call setGradsVar(jl, k, nvar, resten_h*86400./real(c_cp), "resh"//cty, 'residuo H J/kg/day', '3d') call setGradsVar(jl, k, nvar, resten_q*86400.*real(c_xlv)/real(c_cp), "resq"//cty, 'residuo q K/day ', '3d') call setGradsVar(jl, k, nvar, subten_t(i, k)*86400., "subt"//cty, 'subT K/day', '3d') call setGradsVar(jl, k, nvar, subten_h(i, k)*86400./real(c_cp), "subh"//cty, 'subH J/kg/day', '3d') call setGradsVar(jl, k, nvar, subten_q(i, k)*86400.*real(c_xlv)/real(c_cp), "subq"//cty, 'subq K/day ', '3d') call setGradsVar(jl, k, nvar, outq(i, k)*86400.*real(c_xlv)/real(c_cp), "outq"//cty, 'outq K/s', '3d') call setGradsVar(jl, k, nvar, outqc(i, k)*86400.*real(c_xlv)/real(c_cp), "outqc"//cty, 'outqc K/day', '3d') call setGradsVar(jl, k, nvar, pre(i)*3600., "precip"//cty, 'precip mm', '2d') call setGradsVar(jl, k, nvar, prec_flx(i, k)*3600., "precflx"//cty, 'prec flx mm', '3d') call setGradsVar(jl, k, nvar, pwo(i, k), "pwo"//cty, ' xx', '3d') call setGradsVar(jl, k, nvar, outu(i, k)*86400., "outu"//cty, 'out_U m/s/day', '3d') call setGradsVar(jl, k, nvar, outv(i, k)*86400., "outv"//cty, 'out_V m/s/day', '3d') call setGradsVar(jl, k, nvar, xmb(i), "xmb"//cty, 'xmb kg/m2/s', '2d') call setGradsVar(jl, k, nvar, vvel2d(i, k), "W2d"//cty, 'W /m/s', '3d') call setGradsVar(jl, k, nvar, vvel1d(i), "W1d"//cty, 'W1s /m/s', '2d') call setGradsVar(jl, k, nvar, us(i, k), "us"//cty, 'U /m/s', '3d') call setGradsVar(jl, k, nvar, outu(i, k)*86400./(1.e-16 + xmb(i)), "delu"//cty, 'dellu', '3d') call setGradsVar(jl, k, nvar, evap_bcb(i, k)*1000., "evcb"//cty, 'g/kg', '3d') call setGradsVar(jl, k, nvar, tot_pw_up_chem(1, i), "pwup"//cty, 'pwup', '2d') call setGradsVar(jl, k, nvar, tot_pw_dn_chem(1, i), "pwdn"//cty, 'pwdn', '2d') !---- !---- call setGradsVar(jl, k, nvar, xmb(i)*dellah(i, k)*86400./real(c_cp), "delh"//cty, 'dellah K/day', '3d') call setGradsVar(jl, k, nvar, xmb(i)*dellaq(i, k)*86400.*real(c_xlv)/real(c_cp), "dellq"//cty, 'dellaq K/day', '3d') call setGradsVar(jl, k, nvar, xmb(i)*dellaqc(i, k)*86400.*real(c_xlv)/real(c_cp), "dellqc"//cty, 'dellaqc K/day' & , '3d') call setGradsVar(jl, k, nvar, xmb(i), "xmb"//cty, 'm flux up (kg/s/m^2)', '2d') call setGradsVar(jl, k, nvar, aa1(i), "aa1"//cty, 'AA1 J/kg3)', '2d') call setGradsVar(jl, k, nvar, float(ierr(i)), "ierr"//cty, 'ierr #', '2d') call setGradsVar(jl, k, nvar, xmb(i)*dd_massentro(i, k), "ddent"//cty, 'dd_massentr(kg/s/m^2)', '3d') call setGradsVar(jl, k, nvar, xmb(i)*dd_massdetro(i, k), "dddet"//cty, 'dd_massdetr(kg/s/m^2)', '3d') !! go to 333 call setGradsVar(jl, k, nvar, hc(i, k), "hc"//cty, ' hc', '3d') call setGradsVar(jl, k, nvar, hco(i, k), "hco"//cty, ' hco', '3d') call setGradsVar(jl, k, nvar, dby(i, k), "dby"//cty, ' dbuo', '3d') !call set_grads_var(jl,k,nvar,QCUP(i,k),"qcup"//cty ,'C_UP','3d') call setGradsVar(jl, k, nvar, t_cup(i, k) - 273.15, "te"//cty, ' K', '3d') call setGradsVar(jl, k, nvar, 1000.*q_cup(i, k), "qe"//cty, ' kg kg-1', '3d') call setGradsVar(jl, k, nvar, he_cup(i, k), "he"//cty, ' he', '3d') call setGradsVar(jl, k, nvar, HKB(i), "hkb"//cty, ' H', '2d') call setGradsVar(jl, k, nvar, HKB(i), "hkb"//cty, ' H', '2d') call setGradsVar(jl, k, nvar, 1000.*zqexec(i), "qex"//cty, ' qex', '2d') call setGradsVar(jl, k, nvar, z_cup(i, max(1, k22(i))), "zs"//cty, ' m', '2d') call setGradsVar(jl, k, nvar, z_cup(i, max(1, kbcon(i))), "zbcon"//cty, ' m', '2d') call setGradsVar(jl, k, nvar, z_cup(i, max(1, ktop(i))), "ztop"//cty, ' m', '2d') call setGradsVar(jl, k, nvar, z_cup(i, max(1, klcl(i))), "zlcl"//cty, ' m', '2d') call setGradsVar(jl, k, nvar, z_cup(i, max(1, jmin(i))), "zjmin"//cty, ' m', '2d') call setGradsVar(jl, k, nvar, zws(i), "ws"//cty, ' m/s', '2d') call setGradsVar(jl, k, nvar, clfrac(i, k), "clfrac"//cty, 'shcf #', '3d') call setGradsVar(jl, k, nvar, entr_rate_2d(i, k), "entr"//cty, ' m-1', '3d') call setGradsVar(jl, k, nvar, cd(i, k), "detr"//cty, ' m-1', '3d') call setGradsVar(jl, k, nvar, pwdo(i, k), "pwd"//cty, ' xx', '3d') call setGradsVar(jl, k, nvar, edto(i), "edt"//cty, 'edt kg/m2/s', '2d') call setGradsVar(jl, k, nvar, e_dn, "EVAP"//cty, ' xx', '3d') call setGradsVar(jl, k, nvar, c_up, "CUP"//cty, ' xx', '3d') ! call set_grads_var(jl,k,nvar,trash,"TUP"//cty ,' xx','3d') ! call set_grads_var(jl,k,nvar,trash2,"TDN"//cty ,' xx','3d') call setGradsVar(jl, k, nvar, trash, "F1"//cty, ' F1', '3d') call setGradsVar(jl, k, nvar, trash2, "F2"//cty, ' F2', '3d') call setGradsVar(jl, k, nvar, p_liq_ice(i, k), "pli"//cty, '#', '3d') call setGradsVar(jl, k, nvar, melting_layer(i, k), "cpli"//cty, '#', '3d') call setGradsVar(jl, k, nvar, t(i, k), "t"//cty, 'temp K', '3d') call setGradsVar(jl, k, nvar, tn(i, k), "tn"//cty, 'temp K', '3d') call setGradsVar(jl, k, nvar, 1000.*q(i, k), "q"//cty, 'q g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qo(i, k), "qn"//cty, 'q g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qrco(i, k), "qrc"//cty, 'q g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*(q(i, k) + outq(i, k)*dtime), "qnc"//cty, 'q upd conv g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*(qo(i, k) + outq(i, k)*dtime), "qnall"//cty, 'q upd all g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qrr(i, k), "qrr"//cty, 'qrr g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qco(i, k), "qc"//cty, 'qc g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qo_cup(i, k), "qcup"//cty, 'qc g/kg', '3d') call setGradsVar(jl, k, nvar, 1000.*qeso_cup(i, k), "qescup"//cty, 'qc g/kg', '3d') !~ call set_grads_var(jl,k,nvar,aa0(i),"a0"//cty,'aa0','2d') !~ call set_grads_var(jl,k,nvar,aa1_fa(i),"aa1fa"//cty,'aa1fa','2d') !~ call set_grads_var(jl,k,nvar,aa1_bl(i),"aa1bl"//cty,'aa1bl','2d') !~ call set_grads_var(jl,k,nvar,aa0_bl(i),"aa0bl"//cty,'aa0bl','2d') !~ call set_grads_var(jl,k,nvar,aa1(i),"a1"//cty,'aa1','2d') !~ call set_grads_var(jl,k,nvar,aa1(i)/(1.e-6+tau_ecmwf(i)),"mb13"//cty,'aa0','2d') !~ call set_grads_var(jl,k,nvar,xaa0(i),"xa0"//cty,'xaa0','2d') !~ call set_grads_var(jl,k,nvar,(XAA0(I)-AA1(I))/MBDT(I),"xk"//cty,'xk','2d') 333 continue end do if (wrtgrads .and. .not. p_use_gate) then call wrtBinCtl(1, kte, po(1, 1:kte), cumulus) end if end do end if !- end : for GATE soundings------------------------------------------- ! ! !-------------------------- not in use ------------------------------------------------------! !--- get cloud fraction ! ! do i=its,itf ! clfrac(i,:)=0. ! if(ierr(i) /= 0) cycle ! dummy1(kts:ktf) = xmb(i)* zuo(i,kts:ktf) ! dummy2(kts:ktf) = 100.*po_cup(i,kts:ktf) ! call get_cloud_fraction(ktf,kts,ktf & ! ,dummy2(kts:ktf),zo_cup(i,kts:ktf),tn_cup(i,kts:ktf),qo_cup(i,kts:ktf) & ! ,qco (i,kts:ktf), qrco(i,kts:ktf), dummy1(kts:ktf),clfrac(i,kts:ktf) ) ! enddo !--------------------------------------------------------------------------------------------! ! end subroutine cupGf !--------------------------------------------------------------------------------------------------- function genRandom(its, ite, use_random_num) result(random) !! Generate a random array !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! Generate a random array !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'genRandom' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: its integer, intent(in) :: ite real, intent(in) :: use_random_num !Local variables: real :: random(its:ite) integer :: i integer(8) :: iran, ranseed = 0 !Code: call system_clock(ranseed) ranseed = mod(ranseed, 2147483646) + 1 !seed between 1 and 2^31-2 iran = -ranseed !-- Ran1 produces numbers between [ 0,1] !-- random will be between [-1,1] !-- with use_random_num the interval will be [-use_random_num,+use_random_num] do i = its, ite random(i) = use_random_num*2.0*(0.5 - real(Ran1(IRAN), 4)) !print*,"ran=",i,random(i) end do if (maxval(abs(random)) > use_random_num) stop "random > use_random_num" end function genRandom subroutine cupEnv(z_heights, qes, he, hes, temp_env, mixratio_env, press_env, z1, psur, ierr, itest, itf, ktf & , its, ite, kts, kte) !! ????? !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! ????? !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupEnv' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, itest integer, intent(in) :: ierr(its:ite) real, intent(in) :: press_env(its:ite, kts:kte) !! environmental pressure real, intent(in) :: temp_env(its:ite, kts:kte) !! environmental temp real, intent(in) :: mixratio_env(its:ite, kts:kte) !! environmental mixing ratio real, intent(in) :: psur(its:ite) !! surface pressure real, intent(in) :: z1(its:ite) !! terrain elevation real, intent(inout) :: z_heights(its:ite, kts:kte) !! environmental heights real, intent(out) :: he(its:ite, kts:kte) !! environmental moist static energy real, intent(out) :: hes(its:ite, kts:kte) !! environmental saturation moist static energy real, intent(out) :: qes(its:ite, kts:kte) !! environmental saturation mixing ratio !Local variables integer :: i, k, iph !real, dimension (1:2) :: ae,be,ht real, dimension(its:ite, kts:kte) :: tv !! environmental virtual temp real :: e, tvbar, pqsat ! real, external :: satvap ! real :: satvap !Code: he = 0.0 hes = 0.0 qes = 0.0 if (SATUR_CALC == 0) then do k = kts, ktf do i = its, itf if (ierr(i) .eq. 0) then e = SatVap(temp_env(i, k)) qes(i, k) = 0.622*e/max(1.e-8, (press_env(i, k) - e)) if (qes(i, k) .le. 1.e-08) qes(i, k) = 1.e-08 if (qes(i, k) .gt. c_max_qsat) qes(i, k) = c_max_qsat if (qes(i, k) .lt. mixratio_env(i, k)) qes(i, k) = mixratio_env(i, k) ! IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K) tv(i, k) = temp_env(i, k) + .608*mixratio_env(i, k)*temp_env(i, k) end if end do end do else !--- better formulation for the mixed phase regime do k = kts, ktf do i = its, itf if (ierr(i) .eq. 0) then pqsat = SaturSpecHum(temp_env(i, k), press_env(i, k)) qes(i, k) = pqsat !print*,"qes=",k,p(i,k),1000*qes(i,k),1000*pqsat qes(i, k) = min(c_max_qsat, max(1.e-08, qes(i, k))) qes(i, k) = max(qes(i, k), mixratio_env(i, k)) tv(i, k) = temp_env(i, k) + .608*mixratio_env(i, k)*temp_env(i, k) end if end do end do end if !--- z's are calculated with changed h's and q's and t's !--- if itest=2 if (itest .eq. 1 .or. itest .eq. 0) then do i = its, itf if (ierr(i) .eq. 0) then z_heights(i, 1) = max(0., z1(i)) - (Alog(press_env(i, 1)) - Alog(psur(i)))*287.*tv(i, 1)/c_grav end if end do ! --- calculate heights do k = kts + 1, ktf do i = its, itf if (ierr(i) .eq. 0) then tvbar = .5*tv(i, k) + .5*tv(i, k - 1) z_heights(i, k) = z_heights(i, k - 1) - (Alog(press_env(i, k)) - Alog(press_env(i, k - 1)))*287.*tvbar/c_grav end if end do end do else if (itest .eq. 2) then do k = kts, ktf do i = its, itf if (ierr(i) .eq. 0) then z_heights(i, k) = (he(i, k) - 1004.*temp_env(i, k) - 2.5e6*mixratio_env(i, k))/c_grav z_heights(i, k) = max(1.e-3, z_heights(i, k)) end if end do end do else if (itest .eq. -1) then end if !--- calculate moist static energy - HE ! saturated moist static energy - HES do k = kts, ktf do i = its, itf if (ierr(i) /= 0) cycle if (itest .le. 0) he(i, k) = c_grav*z_heights(i, k) + real(c_cp)*temp_env(i, k) + real(c_xlv)*mixratio_env(i, k) hes(i, k) = c_grav*z_heights(i, k) + real(c_cp)*temp_env(i, k) + real(c_xlv)*qes(i, k) if (he(i, k) .ge. hes(i, k)) he(i, k) = hes(i, k) end do end do end subroutine cupEnv !----------------------------------------------------------------------------------------------------------------------- subroutine sound(part, cumulus, int_time, dtime, ens4, itf, ktf, its, ite, kts, kte, xlats, xlons, jcol, whoami_all & , z, qes, he, hes, t, q, po, z1, psur, zo, qeso, heo, heso, tn, qo, us, vs, omeg, xz, h_sfc_flux, le_sfc_flux & , tsur, dx, stochastic_sig, zws, ztexec, zqexec, xland, kpbl, k22, klcl, kbcon, ktop, aa0, aa1, sig, xaa0, hkb & , xmb, pre, edto, zo_cup, dhdt, rho, zuo, zdo, up_massentro, up_massdetro, outt, outq, outqc, outu, outv) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'sound' ! Nome da subrotina real, parameter :: p_latsnd = -10., p_lonsnd = 301., p_deltx = 0.2 ! real, parameter :: LATSND= -8.72, LONSND= 186.6, DELTX=0.2 !Variables (input, output, inout) integer, intent(in) ::ens4, itf, ktf, its, ite, kts, kte, jcol, whoami_all, part integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: zuo(its:ite, kts:kte) real, intent(in) :: zdo(its:ite, kts:kte) real, intent(in) :: up_massentro(its:ite, kts:kte) real, intent(in) :: up_massdetro(its:ite, kts:kte) real, intent(in) :: outt(its:ite, kts:kte) real, intent(in) :: outq(its:ite, kts:kte) real, intent(in) :: outqc(its:ite, kts:kte) real, intent(in) :: outu(its:ite, kts:kte) real, intent(in) :: outv(its:ite, kts:kte) real, intent(in) :: stochastic_sig(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: aa0(its:ite) real, intent(in) :: aa1(its:ite) real, intent(in) :: xaa0(its:ite) real, intent(in) :: hkb(its:ite) real, intent(in) :: xmb(its:ite) real, intent(in) :: pre(its:ite) real, intent(in) :: edto(its:ite) real, intent(in) :: sig(its:ite) real, intent(in) :: int_time, dtime character(len=*), intent(in) :: cumulus integer, intent(inout) :: kpbl(its:ite) real, intent(inout) :: h_sfc_flux(its:ite) real, intent(inout) :: le_sfc_flux(its:ite) real, intent(inout) :: tsur(its:ite) real, intent(inout) :: dx(its:ite) real, intent(inout) :: zws(its:ite) real, intent(inout) :: ztexec(its:ite) real, intent(inout) :: zqexec(its:ite) real, intent(inout) :: xlats(its:ite) real, intent(inout) :: xlons(its:ite) real, intent(inout) :: z1(its:ite) real, intent(inout) :: psur(its:ite) real, intent(inout) :: qes(its:ite, kts:kte) real, intent(inout) :: he(its:ite, kts:kte) real, intent(inout) :: hes(its:ite, kts:kte) real, intent(inout) :: t(its:ite, kts:kte) real, intent(inout) :: q(its:ite, kts:kte) real, intent(inout) :: po(its:ite, kts:kte) real, intent(inout) :: zo(its:ite, kts:kte) real, intent(inout) :: heo(its:ite, kts:kte) real, intent(inout) :: heso(its:ite, kts:kte) real, intent(inout) :: tn(its:ite, kts:kte) real, intent(inout) :: qo(its:ite, kts:kte) real, intent(inout) :: us(its:ite, kts:kte) real, intent(inout) :: vs(its:ite, kts:kte) real, intent(inout) :: dhdt(its:ite, kts:kte) real, intent(inout) :: omeg(its:ite, kts:kte, 1:ens4) real, intent(out) :: z(its:ite, kts:kte) real, intent(out) :: xz(its:ite, kts:kte) real, intent(out) :: qeso(its:ite, kts:kte) real, intent(out) :: rho(its:ite, kts:kte) !---locals integer :: i, k, x_kte, x_i, x_jcol, x_k, x_whoami_all real :: x_time real, dimension(its:ite) :: x_stochastic_sig, x_xland character(len=200) :: lixo if (trim(rundata) == "NONE") then if (mod(int_time, 3600.) < dtime) then open (15, file="dataLXXX.dat_"//trim(cumulus), status='unknown', position="APPEND") if (part == 1) then do i = its, itf if (xlats(i) > p_latsnd - p_deltx .and. xlats(i) < p_latsnd + p_deltx) then if (xlons(i) > p_lonsnd - p_deltx .and. xlons(i) < p_lonsnd + p_deltx) then print *, "===============================================" print *, "00>", i, jcol, xlats(i), xlons(i), whoami_all, int_time/3600. call flush (6) write (15, *) "====begin=====" write (15, *) "i,jcol,xlats(i),xlons(i),int_time/3600." write (15, *) i, jcol, xlats(i), xlons(i), int_time/3600. write (15, *) "kte,z1(i),psur(i),tsur(i),xland(i)" write (15, *) kte, z1(i), psur(i), tsur(i), xland(i) write (15, *) "h_sfc_flux(i),le_sfc_flux(i),ztexec(i),zqexec(i)" write (15, *) h_sfc_flux(i), le_sfc_flux(i), ztexec(i), zqexec(i) write (15, *) "stochastic_sig(i), dx(i),zws(i),kpbl(i)" write (15, *) stochastic_sig(i), dx(i), zws(i), kpbl(i) write (15, *) "=>k zo po t tn-t q qo-q us vs qes he hes qeso-qes heo-he heso-hes dhdt omeg" do k = kts, kte write (15, 100) k, zo(i, k), po(i, k), t(i, k), tn(i, k) - t(i, k), q(i, k), qo(i, k) - q(i, k) & , us(i, k), vs(i, k), qes(i, k), he(i, k), hes(i, k), qeso(i, k) - qes(i, k), heo(i, k) - he(i, k) & , heso(i, k) - hes(i, k), dhdt(i, k), omeg(i, k, 1:ens4) end do end if end if end do else do i = its, itf if (xlats(i) > p_latsnd - p_deltx .and. xlats(i) < p_latsnd + p_deltx) then if (xlons(i) > p_lonsnd - p_deltx .and. xlons(i) < p_lonsnd + p_deltx) then write (15, *) "====outputs=======" write (15, *) "L=", i, jcol, xlats(i), xlons(i), whoami_all write (15, *) "A=", aa0(i), aa1(i), xaa0(i), sig(i) write (15, *) "K=", k22(i), klcl(i), kpbl(i), kbcon(i), ktop(i) write (15, *) "Z=", zo_cup(i, k22(i)) - z1(i), zo_cup(i, klcl(i)) - z1(i), zo_cup(i, kpbl(i)) - z1(i) & , zo_cup(i, kbcon(i)) - z1(i), zo_cup(i, ktop(i)) - z1(i) write (15, *) "H=", hkb(i)/real(c_cp), edto(i) write (15, *) "T=", maxval(outt(i, 1:ktop(i)))*86400., maxval(outq(i, 1:ktop(i)))*86400.*1000., & minval(outt(i, 1:ktop(i)))*86400., minval(outq(i, 1:ktop(i)))*86400.*1000. write (15, *) "P=", xmb(i)*1000., 'g/m2/s', 3600*pre(i), 'mm/h' if (xmb(i) > 0.0) then write (15, *) "=> k zo po zuo,zdo,up_massentro,up_massdetro,outt, outq,outqc,outu,outv" do k = kts, kte write (15, 101) k, zo(i, k), po(i, k), zuo(i, k), zdo(i, k), up_massentro(i, k), up_massdetro(i, k) & , outt(i, k)*86400., outq(i, k)*86400.*1000., outqc(i, k)*86400.*1000., outu(i, k) & *86400., outv(i, k)*86400. end do end if write (15, *) "=====end==========" end if end if end do end if close (15) end if else if (part == 1) then open (15, file=trim(rundata), status='old') i = 1 read (15, *) lixo read (15, *) lixo read (15, *) x_i, x_jcol, xlats(i), xlons(i), x_time read (15, *) lixo read (15, *) x_kte, z1(i), psur(i), tsur(i), x_xland(i) !-- check if (x_kte .ne. kte) stop " X_kte .ne. kte " read (15, *) lixo read (15, *) h_sfc_flux(i), le_sfc_flux(i), ztexec(i), zqexec(i) read (15, *) lixo read (15, *) x_stochastic_sig(i), dx(i), zws(i), kpbl(i) read (15, *) lixo do k = kts, kte read (15, 100) x_k, zo(i, k), po(i, k), t(i, k), tn(i, k), q(i, k), qo(i, k), us(i, k), vs(i, k) , qes(i, k) & , he(i, k), hes(i, k), qeso(i, k), heo(i, k), heso(i, k), dhdt(i, k), omeg(i, k, 1:ens4) end do close (15) !---settings tn(i, :) = t(i, :) + tn(i, :) ! input is delta(T) qo(i, :) = q(i, :) + qo(i, :) ! input is delta(Q) qeso(i, :) = qes(i, :) + qeso(i, :) ! input is delta(Q) heo(i, :) = he(i, :) + heo(i, :) ! input is delta(H) heso(i, :) = hes(i, :) + heso(i, :) ! input is delta(HO) xz(i, :) = zo(i, :) z(i, :) = zo(i, :) rho(i, :) = 1.e2*po(i, :)/(c_rgas*t(i, :)) else do i = its, itf if (xlats(i) > p_latsnd - p_deltx .and. xlats(i) < p_latsnd + p_deltx) then if (xlons(i) > p_lonsnd - p_deltx .and. xlons(i) < p_lonsnd + p_deltx) then print *, "====outputs=======" print *, "A=", aa0(i), aa1(i), xaa0(i), sig(i) print *, "K=", k22(i), klcl(i), kpbl(i), kbcon(i), ktop(i) print *, "Z=", zo_cup(i, k22(i)) - z1(i), zo_cup(i, klcl(i)) - z1(i), zo_cup(i, kpbl(i)) - z1(i) & , zo_cup(i, kbcon(i)) - z1(i), zo_cup(i, ktop(i)) - z1(i) print *, "H=", hkb(i)/real(c_cp), edto(i) print *, "T=", maxval(outt(i, 1:ktop(i)))*86400., maxval(outq(i, 1:ktop(i)))*86400.*1000. & , minval(outt(i, 1:ktop(i)))*86400., minval(outq(i, 1:ktop(i)))*86400.*1000. print *, "P=", xmb(i)*1000., 'g/m2/s', 3600*pre(i), 'mm/h' if (xmb(i) > 0.0) then print *, "=> k zo po zuo,zdo,up_massentro,up_massdetro,outt, outq,outqc,outu,outv" do k = kts, kte write (*, 101) k, zo(i, k), po(i, k) & , zuo(i, k), zdo(i, k), up_massentro(i, k), up_massdetro(i, k), outt(i, k)*86400. & , outq(i, k)*86400.*1000., outqc(i, k)*86400.*1000., outu(i, k)*86400., outv(i, k)*86400. end do end if end if end if end do end if end if 100 format(1x, i4, 16e16.8) 101 format(1x, i4, 11e16.8) end subroutine sound !------------------------------------------------------------------------------------ subroutine cupEnvCLev(temp_env, qes, q, he, hes, z_heights, pres_env, qes_cup, q_cup, he_cup, us, vs, u_cup, v_cup & , hes_cup, z_cup, p_cup, gamma_cup, t_cup, psur, tsur, ierr, z1, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupEnvCLev' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) real, intent(in) :: qes(its:ite, kts:kte) !! environmental saturation mixing ratio real, intent(in) :: q(its:ite, kts:kte) !! environmental mixing ratio real, intent(in) :: he(its:ite, kts:kte) !! environmental moist static energy real, intent(in) :: hes(its:ite, kts:kte) !! environmental saturation moist static energy real, intent(in) :: z_heights(its:ite, kts:kte) !! environmental heights real, intent(in) :: pres_env(its:ite, kts:kte) !! environmental pressure real, intent(in) :: temp_env(its:ite, kts:kte) !! environmental temp real, intent(in) :: us(its:ite, kts:kte) !! real, intent(in) :: vs(its:ite, kts:kte) !! real, intent(in) :: psur(its:ite) !! surface pressure real, intent(in) :: z1(its:ite) !! terrain elevation real, intent(in) :: tsur(its:ite) !! surface temperature real, intent(out) :: qes_cup(its:ite, kts:kte) !! environmental saturation mixing ratio on cloud levels real, intent(out) :: q_cup(its:ite, kts:kte) !! environmental mixing ratio on cloud levels real, intent(out) :: he_cup(its:ite, kts:kte) !! environmental moist static energy on cloud levels real, intent(out) :: hes_cup(its:ite, kts:kte) !! environmental saturation moist static energy on cloud levels real, intent(out) :: z_cup(its:ite, kts:kte) !! environmental heights on cloud levels real, intent(out) :: p_cup(its:ite, kts:kte) !! environmental pressure on cloud levels real, intent(out) :: gamma_cup(its:ite, kts:kte) !! gamma on cloud levels real, intent(out) :: t_cup(its:ite, kts:kte) !! environmental temp on cloud levels real, intent(out) :: u_cup(its:ite, kts:kte) real, intent(out) :: v_cup(its:ite, kts:kte) !Local variables: integer :: i, k real :: p1, p2, ct1, ct2, rho integer :: irun = 0 qes_cup = 0. q_cup = 0. hes_cup = 0. he_cup = 0. z_cup = 0. p_cup = 0. t_cup = 0. gamma_cup = 0. u_cup = 0. v_cup = 0. if (CLEV_GRID == 2) then !--original formulation do k = kts + 1, ktf do i = its, itf if (ierr(i) /= 0) cycle qes_cup(i, k) = .5*(qes(i, k - 1) + qes(i, k)) q_cup(i, k) = .5*(q(i, k - 1) + q(i, k)) hes_cup(i, k) = .5*(hes(i, k - 1) + hes(i, k)) he_cup(i, k) = .5*(he(i, k - 1) + he(i, k)) if (he_cup(i, k) .gt. hes_cup(i, k)) he_cup(i, k) = hes_cup(i, k) z_cup(i, k) = .5*(z_heights(i, k - 1) + z_heights(i, k)) p_cup(i, k) = .5*(pres_env(i, k - 1) + pres_env(i, k)) t_cup(i, k) = .5*(temp_env(i, k - 1) + temp_env(i, k)) gamma_cup(i, k) = (real(c_xlv)/real(c_cp))*(real(c_xlv)/(c_rv*t_cup(i, k) * t_cup(i, k)))*qes_cup(i, k) u_cup(i, k) = .5*(us(i, k - 1) + us(i, k)) v_cup(i, k) = .5*(vs(i, k - 1) + vs(i, k)) end do end do do i = its, itf if (ierr(i) /= 0) cycle qes_cup(i, 1) = qes(i, 1) q_cup(i, 1) = q(i, 1) !hes_cup(i,1)=hes(i,1) !he_cup(i,1)=he(i,1) hes_cup(i, 1) = c_grav*z1(i) + real(c_cp)*temp_env(i, 1) + real(c_xlv)*qes(i, 1) he_cup(i, 1) = c_grav*z1(i) + real(c_cp)*temp_env(i, 1) + real(c_xlv)*q(i, 1) !z_cup(i,1)=.5*(z(i,1)+z1(i)) !p_cup(i,1)=.5*(p(i,1)+psur(i)) z_cup(i, 1) = z1(i) p_cup(i, 1) = psur(i) t_cup(i, 1) = temp_env(i, 1) gamma_cup(i, 1) = real(c_xlv)/real(c_cp)*(real(c_xlv)/(c_rv*t_cup(i, 1) & *t_cup(i, 1)))*qes_cup(i, 1) u_cup(i, 1) = us(i, 1) v_cup(i, 1) = vs(i, 1) end do !do k=kts,ktf ! i=1 ! print*,"air_dens=",k,z_cup(i,k),p_cup(i,k),(p_cup(i,k)-p_cup(i,k+1))/(z_cup(i,k+1)-z_cup(i,k))/g !enddo elseif (CLEV_GRID == 0) then !--- weigthed mean do i = its, itf if (ierr(i) /= 0) cycle p_cup(i, 1) = psur(i) z_cup(i, 1) = z1(i) do k = kts, ktf - 1 p_cup(i, k + 1) = 2.0*pres_env(i, k) - p_cup(i, k) z_cup(i, k + 1) = 2.0*z_heights(i, k) - z_cup(i, k) end do ! ----------- p,T k+1 !p1 ! ----------- p_cup,T_cup k+1 !p2 ! ----------- p,T k ! ! ----------- p_cup,T_cup k do k = kts, ktf - 1 p1 = abs((pres_env(i, k + 1) - p_cup(i, k + 1))/(pres_env(i, k + 1) - pres_env(i, k))) p2 = abs((p_cup(i, k + 1) - pres_env(i, k))/(pres_env(i, k + 1) - pres_env(i, k))) t_cup(i, k + 1) = p1*temp_env(i, k) + p2*temp_env(i, k + 1) u_cup(i, k + 1) = p1*us(i, k) + p2*us(i, k + 1) v_cup(i, k + 1) = p1*vs(i, k) + p2*vs(i, k + 1) q_cup(i, k + 1) = p1*q(i, k) + p2*q(i, k + 1) he_cup(i, k + 1) = p1*he(i, k) + p2*he(i, k + 1) qes_cup(i, k + 1) = p1*qes(i, k) + p2*qes(i, k + 1) hes_cup(i, k + 1) = p1*hes(i, k) + p2*hes(i, k + 1) if (he_cup(i, k + 1) .gt. hes_cup(i, k + 1)) he_cup(i, k + 1) = hes_cup(i, k + 1) gamma_cup(i, k + 1) = (real(c_xlv)/real(c_cp))*(real(c_xlv)/(c_rv*t_cup(i, k + 1) * t_cup(i, k + 1))) & * qes_cup(i, k + 1) end do !--- surface level from X(kts) and X_cup(kts+1) determine X_cup(kts) k = kts p1 = abs(pres_env(i, k) - p_cup(i, k)) p2 = abs(p_cup(i, k + 1) - p_cup(i, k)) ct1 = (p1 + p2)/p2 ct2 = p1/p2 t_cup(i, k) = ct1*temp_env(i, k) - ct2*t_cup(i, k + 1) q_cup(i, k) = ct1*q(i, k) - ct2*q_cup(i, k + 1) u_cup(i, k) = ct1*us(i, k) - ct2*u_cup(i, k + 1) v_cup(i, k) = ct1*vs(i, k) - ct2*v_cup(i, k + 1) qes_cup(i, k) = ct1*qes(i, k) - ct2*qes_cup(i, k + 1) hes_cup(i, k) = c_grav*z_cup(i, k) + real(c_cp)*t_cup(i, k) + real(c_xlv)*qes_cup(i, k) he_cup(i, k) = c_grav*z_cup(i, k) + real(c_cp)*t_cup(i, k) + real(c_xlv)*q_cup(i, k) if (he_cup(i, k) .gt. hes_cup(i, k)) he_cup(i, k) = hes_cup(i, k) gamma_cup(i, k) = real(c_xlv)/real(c_cp)*(real(c_xlv)/(c_rv*t_cup(i, k)*t_cup(i, k)))*qes_cup(i, k) end do elseif (CLEV_GRID == 1) then !--- based on Tiedke (1989) do i = its, itf if (ierr(i) /= 0) cycle do k = ktf, kts + 1, -1 qes_cup(i, k) = qes(i, k) q_cup(i, k) = q(i, k) p_cup(i, k) = 0.5*(pres_env(i, k - 1) + pres_env(i, k)) z_cup(i, k) = 0.5*(z_heights(i, k - 1) + z_heights(i, k)) t_cup(i, k) = (max(real(c_cp)*temp_env(i, k - 1) + c_grav*z_heights(i, k - 1), real(c_cp)*temp_env(i, k) + c_grav & * z_heights(i, k)) - c_grav*z_cup(i, k))/real(c_cp) if (qes(i, k) < c_max_qsat) & call getInterp(qes_cup(i, k), t_cup(i, k), p_cup(i, k), qes_cup(i, k), t_cup(i, k)) q_cup(i, k) = min(q(i, k), qes(i, k)) + qes_cup(i, k) - qes(i, k) q_cup(i, k) = max(q_cup(i, k), 0.0) end do !---level kts qes_cup(i, 1) = qes(i, 1) q_cup(i, 1) = q(i, 1) z_cup(i, 1) = z1(i) p_cup(i, 1) = psur(i) t_cup(i, 1) = (real(c_cp)*temp_env(i, 1) + c_grav*z_heights(i, 1) - c_grav*z_cup(i, 1))/real(c_cp) hes_cup(i, 1) = c_grav*z_cup(i, 1) + real(c_cp)*t_cup(i, 1) + real(c_xlv)*qes_cup(i, 1) he_cup(i, 1) = c_grav*z_cup(i, 1) + real(c_cp)*t_cup(i, 1) + real(c_xlv)*q_cup(i, 1) gamma_cup(i, 1) = real(c_xlv)/real(c_cp)*(real(c_xlv)/(c_rv*t_cup(i, 1)*t_cup(i, 1)))*qes_cup(i, 1) u_cup(i, 1) = us(i, 1) v_cup(i, 1) = vs(i, 1) do k = ktf, kts + 1, -1 p1 = max(real(c_cp)*t_cup(i, k) + c_grav*z_cup(i, k), real(c_cp)*t_cup(i, k - 1) + c_grav*z_cup(i, k - 1)) t_cup(i, k) = (p1 - c_grav*z_cup(i, k))/real(c_cp) hes_cup(i, k) = real(c_cp)*t_cup(i, k) + real(c_xlv)*qes_cup(i, k) + c_grav*z_cup(i, k) he_cup(i, k) = real(c_cp)*t_cup(i, k) + real(c_xlv)*q_cup(i, k) + c_grav*z_cup(i, k) if (he_cup(i, k) .gt. hes_cup(i, k)) he_cup(i, k) = hes_cup(i, k) gamma_cup(i, k) = (real(c_xlv)/real(c_cp))*(real(c_xlv)/(c_rv*t_cup(i, k)*t_cup(i, k)))*qes_cup(i, k) u_cup(i, k) = us(i, k) v_cup(i, k) = vs(i, k) end do end do else stop "cup_env_clev" end if return !IF( MAPL_AM_I_ROOT() .and. irun == 0) then irun = 1 do i = its, itf if (ierr(i) == 0) then do k = kts, kte - 1 rho = 100*(p_cup(i, k) - p_cup(i, k + 1))/(z_cup(i, k + 1) - z_cup(i, k))/c_grav ! air dens by hidrostatic balance (kg/m3) write (23, 101) i, k, z_cup(i, k), p_cup(i, k), t_cup(i, k), q_cup(i, k)*1000., he_cup(i, k), u_cup(i, k) & , v_cup(i, k), rho rho = 100*(pres_env(i, k) - pres_env(i, k + 1))/(z_heights(i, k + 1) - z_heights(i, k))/c_grav write (25, 101) i, k, z_heights(i, k), pres_env(i, k), temp_env(i, k), q(i, k)*1000., he(i, k), us(i, k), vs(i, k) & , rho 101 format(2i3, 8f15.5) end do exit ! goto 400 end if end do end subroutine cupEnvCLev !------------------------------------------------------------------------------------ subroutine getPartitionLiqIce(ierr, tn, z1, zo_cup, po_cup, p_liq_ice, melting_layer, itf, ktf, its, ite, kts, kte, cumulus) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getPartitionLiqIce' ! Nome da subrotina real, parameter :: p_t1 = 276.16, p_z_meltlayer1 = 4000. real, parameter :: p_z_meltlayer2 = 6000., p_delt = 3. !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) real, intent(in) :: tn(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: z1(its:ite) character(len=*), intent(in) :: cumulus real, intent(inout) :: p_liq_ice(its:ite, kts:kte) real, intent(inout) :: melting_layer(its:ite, kts:kte) !Local variables: integer :: i, k real :: dp, height real, dimension(its:ite) :: norm p_liq_ice(:, :) = 1. melting_layer(:, :) = 0. !-- get function of T for partition of total condensate into liq and ice phases. if (p_melt_glac .and. trim(cumulus) == 'deep') then do k = kts, ktf do i = its, itf if (ierr(i) /= 0) cycle p_liq_ice(i, k) = FractLiqF(tn(i, k)) end do end do !-- define the melting layer (the layer will be between T_0+1 < TEMP < T_1 !-- definition em terms of temperatura do k = kts, ktf do i = its, itf if (ierr(i) /= 0) cycle if (tn(i, k) <= c_t_0 - p_delt) then melting_layer(i, k) = 0. elseif (tn(i, k) < c_t_0 + p_delt .and. tn(i, k) > c_t_0 - p_delt) then melting_layer(i, k) = ((tn(i, k) - (c_t_0 - p_delt))/(2.*p_delt))**2 else melting_layer(i, k) = 1. end if melting_layer(i, k) = melting_layer(i, k)*(1.-melting_layer(i, k)) end do end do !go to 655 !650 continue ! !-- definition em terms of height above local terrain ! DO k=kts,ktf ! DO i=its,itf ! if(ierr(i) /= 0) cycle ! height= zo_cup(i,k)+z1(i) ! if (height > Z_meltlayer2 ) then ! melting_layer(i,k) = 0. ! ! elseif(height > Z_meltlayer1 .and. height < Z_meltlayer2 ) then ! ! melting_layer(i,k) = ((height - Z_meltlayer1)/(Z_meltlayer2-Z_meltlayer1))**2. ! ! ! else ! melting_layer(i,k) = 1. ! endif ! melting_layer(i,k) = melting_layer(i,k)*(1.-melting_layer(i,k)) ! ENDDO ! ENDDO ! ! ! 655 continue !-normalize vertical integral of melting_layer to 1 norm(:) = 0. do k = kts, ktf - 1 do i = its, itf if (ierr(i) /= 0) cycle dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) norm(i) = norm(i) + melting_layer(i, k)*dp/c_grav end do end do do i = its, itf if (ierr(i) /= 0) cycle melting_layer(i, :) = melting_layer(i, :)/(norm(i) + 1.e-6)*(100*(po_cup(i, kts) - po_cup(i, ktf))/c_grav) !print*,"i2=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) end do !--check ! norm(:)=0. ! DO k=kts,ktf-1 ! DO i=its,itf ! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) ! norm(i) = norm(i) + melting_layer(i,k)*dp/g/(100*(po_cup(i,kts)-po_cup(i,ktf))/g) ! !print*,"n=",i,k,norm(i) ! ENDDO ! ENDDO !~ ELSE !~ p_liq_ice (:,:) = 1. !~ melting_layer(:,:) = 0. end if end subroutine getPartitionLiqIce !------------------------------------------------------------------------------------ subroutine precipCwvFactor(itf, ktf, its, ite, kts, kte, ierr, t, po, qo, po_cup, cumulus, p_cwv_ave) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'precipCwvFactor' ! Nome da subrotina real, parameter :: p_fpkup = 0.8 !! 90% of precip occurs above 80% of critical w !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) real, intent(in) :: t(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) character(len=*), intent(in) :: cumulus real, intent(out) :: p_cwv_ave(its:ite) !Local variables: integer :: i, k real :: dp, trash real, dimension(its:ite) :: w_col, w_ccrit, t_troposph p_cwv_ave = 0.0 if (trim(cumulus) /= 'deep') return !-- get the pickup of ensemble ave prec, following Neelin et al 2009. do i = its, itf w_col(i) = 0. w_ccrit(i) = 0. t_troposph(i) = 0. if (ierr(i) /= 0) cycle trash = 0. do k = kts, ktf if (po(i, k) .lt. 200.) exit dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) trash = trash + dp/c_grav w_col(i) = w_col(i) + qo(i, k)*dp/c_grav ! unit mm t_troposph(i) = t_troposph(i) + t(i, k)*dp/c_grav end do !--average temperature t_troposph(i) = t_troposph(i)/(1.e-8 + trash)! unit K ! !--- wcrit given by Neelin et al 2009. w_ccrit(i) = max(0., 56.2 + 2.1*(t_troposph(i) - 268.)) ! unit mm ! !--- pickup (normalized by the factor 'a') !-- <p>=a[(w-w_c)/w_c]**beta, a=0.15, beta=0.23 ! p_cwv_ave(i) = (max(0., w_col(i) - p_fpkup*w_ccrit(i))/(1.e-8 + p_fpkup*w_ccrit(i)))**0.23 p_cwv_ave(i) = max(0., min(1., p_cwv_ave(i))) !print*,"NEE=",i,w_col(i),t_troposph(i),w_ccrit(i),p_cwv_ave (i) !print*,"==================================================" end do end subroutine precipCwvFactor !------------------------------------------------------------------------------------ subroutine getCloudBc(cumulus, kts, kte, ktf, xland, po, array, x_aver, k22, add, tpert) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getCloudBc' ! Nome da subrotina real, parameter :: p_frac_ave_layer_ocean = 0.3 !Variables (input, output, inout) integer, intent(in) :: kts, kte, ktf, k22 real, intent(in) :: array(kts:kte) real, intent(in) :: po(kts:kte) real, intent(in) :: xland real, optional, intent(in) :: add real, optional, intent(in) :: tpert(kts:kte) character(len=*), intent(in) :: cumulus real, intent(out) :: x_aver !Local variables: integer :: i, local_order_aver, order_aver, i_beg, i_end, ic real :: count, dp, dp_layer, effec_frac, x_ave_layer !-- dimensions of the average: !-- a) to pick the value at k22 level, instead of an average between !-- (k22-order_aver, ..., k22-1, k22) set order_aver=kts !-- b) to average between kts and k22 => set order_aver = k22 !order_aver = 4 !=> BC_METH 0: average between k22, k22-1, k22-2 ... !=> BC_METH 1: average between ... k22+1,k22, k22-1 ... !-- order_aver = kts !=> average between k22, k22-1 and k22-2 if (BC_METH == 0) then order_aver = 3 local_order_aver = min(k22, order_aver) x_aver = 0. do i = kts, local_order_aver x_aver = x_aver + array(k22 - i + 1) end do x_aver = x_aver/float(local_order_aver) elseif (BC_METH == 1) then effec_frac = (1.-xland) + xland*p_frac_ave_layer_ocean x_ave_layer = ave_layer*effec_frac i_beg = minloc(abs(po(kts:ktf) - (po(k22) + 0.5*x_ave_layer)), 1) i_end = minloc(abs(po(kts:ktf) - (po(k22) - 0.5*x_ave_layer)), 1) i_beg = min(ktf, max(i_beg, kts)) i_end = min(ktf, max(i_end, kts)) if (i_beg >= i_end) then x_aver = array(k22) dp_layer = 0. ic = i_beg else dp_layer = 1.e-06 x_aver = 0. ic = 0 do i = i_beg, ktf dp = -(po(i + 1) - po(i)) if (dp_layer + dp <= x_ave_layer) then dp_layer = dp_layer + dp x_aver = x_aver + array(i)*dp else dp = x_ave_layer - dp_layer dp_layer = dp_layer + dp x_aver = x_aver + array(i)*dp exit end if end do x_aver = x_aver/dp_layer ic = max(i_beg, i) end if !print*,"xaver1=",real(x_aver,4),real(dp_layer,4) !-- this perturbation is included only for MSE if (present(tpert)) x_aver = x_aver + real(c_cp)*maxval(tpert(i_beg:ic)) ! version 2 - maxval in the layer end if if (present(add)) x_aver = x_aver + add end subroutine getCloudBc !------------------------------------------------------------------------------------ subroutine getLcl(t0, pp0, r0, tlcl, plcl, dzlcl) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getLcl' ! Nome da subrotina !Variables (input, output, inout) real, intent(in) :: t0 real, intent(in) :: pp0 real, intent(in) :: r0 real, intent(out) :: tlcl real, intent(out) :: plcl real, intent(out) :: dzlcl !Local variables: integer :: nitt, ip real :: p0k, pi0i, ttth0, ttd, dz, pki, pppi, ti, rvs, e !Code: !real, external :: td,satvap !================ !-simpler,cheaper method ttd = Td(pp0, r0) tlcl = ttd - (0.001296*ttd + 0.1963)*(t0 - ttd) plcl = pp0*(tlcl/t0)**c_cpor dzlcl = 127*(t0 - ttd) if (dzlcl .le. 0.) dzlcl = -999. !print*,"1st meth",tlcl,plcl,dzlcl;call flush(6) return ! !================ ! !-2nd method ! dzlcl=-999. ! ip=0 !11 continue ! ! plcl=pp0 ! tlcl=t0 ! p0k=pp0**rocp ! pi0i=p0k/p00k*cp ! ttth0=t0*p00k/p0k ! ttd=td(pp0,r0) ! dz=cpg*(t0-ttd) ! if(dz.le.0.)then ! dzlcl=-999. ! return ! endif ! do nitt=1,50 ! pki=pi0i-g*dz/(ttth0*(1.+.61*r0)) ! pppi=(pki/cp)**cpor*p00 ! ti=ttth0*pki/cp ! e=100.*satvap(ti) ! rvs= ( 0.622*e )/ max(1.e-8,(pppi-e)) ! !print*,'1',nitt,rvs,r0,ttd,ti,dz ! if(abs(rvs-r0).lt..00003)goto 110 ! ttd=td(pppi,r0) ! dz=dz+cp/g*(ti-ttd) ! !print*,'2',nitt,rvs-r0,ttd,ti,dz ! enddo ! print*, 'no converge in LCL:',t0,pp0,r0 ! ip=ip+1 ! if(ip==1)go to 11 ! return ! !110 continue ! !- solution for LCL ! plcl=pppi ! tlcl=ti ! dzlcl=dz !displacement ! !print*,"2nd meth",tlcl,plcl,dz end subroutine getLcl !end subroutine get_lcl !---------------------------------------------------------------------- subroutine rhControls(itf, ktf, its, ite, kts, kte, ierr, t, po, qo, qeso, po_cup, cumulus, rh_entr_factor, rh_dicycle_fct & , entr_rate_input, entr_rate, xlons, dt) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'rhControls' ! Nome da subrotina real, parameter :: p_ref_local_time = 8., p_ftun3 = 0.25 logical, parameter :: p_free_troposphere = .true. !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) real, intent(in) :: t(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qeso(its:ite, kts:kte) real, intent(in) :: xlons(its:ite) real, intent(in) :: entr_rate_input real, intent(in) :: dt character(len=*), intent(in) :: cumulus real, intent(inout) :: entr_rate(its:ite) real, intent(inout) :: rh_entr_factor(its:ite) real, intent(inout) :: rh_dicycle_fct(its:ite) !Local variables: integer :: i, k real*8 :: y, x real :: dpg, trash, dayhr, p_start = 1000. real, dimension(its:ite) :: frh, dayhrr if (MOIST_TRIGGER /= 2 .and. RH_DICYCLE == 0) return !-- ave rh from 1000 -> 450 hPa, following Tian et al 2022 GRL. ! OR !-- ave rh from 800 -> 450 hPa accounts only for the ´free troposphere' if (p_free_troposphere) p_start = 800. do i = its, itf frh(i) = 0. trash = 0. do k = kts, ktf if (po(i, k) .gt. p_start .and. po(i, k) .lt. 450.) cycle dpg = 100.*(po_cup(i, k) - po_cup(i, k + 1))/c_grav trash = trash + dpg frh(i) = frh(i) + (qo(i, k)/qeso(i, k))*dpg end do !--average relative humidity frh(i) = 100.*frh(i)/(1.e-8 + trash) ! no unit frh(i) = max(1., min(100., frh(i))) ! !--- this is for the moist_trigger = 2 x = dble(frh(i)) y = 9.192833d0 - 0.2529055d0*x + 0.002344832d0*x**2 - 0.000007230408d0*x**3 rh_entr_factor(i) = real(y, 4) !--- local time dayhr = (time_in/3600.+float(itime1_in/100) + float(mod(itime1_in, 100))/60.) dayhrr(i) = mod(dayhr + xlons(i)/15.+24., 24.) !print*,"FRH=",i,frh(i),rh_dicycle_fct(i),dayhrr,time_in/3600.,xlons(i) !print*,"LONS=",i,dayhrr,time_in/3600.,xlons(i) !print*,"==================================================" end do if (MOIST_TRIGGER == 2) then entr_rate(:) = entr_rate_input*rh_entr_factor(:) !print*,"rh-entr-fac",minval(rh_entr_factor),maxval(rh_entr_factor) end if if (RH_DICYCLE == 1) then do i = its, itf !--- ftun3 controls the domain of the dicycle closure ! ftun3 => 1 the closure is insensitive to the mean tropospheric RH ! ftun3 => 0 it depends on the RH, with mininum = ftun3 !rh_dicycle_fct(i) = ftun3 +(1. - ftun3)*& ! (1.-(atan((frh(i)-60.)/10.)+atan(50.))/3.1016)/0.9523154 if (abs(dayhrr(i) - p_ref_local_time) < 1. .or. time_in < dt + 1.) rh_dicycle_fct(i) = p_ftun3 + (1.-p_ftun3) & * (1.-(atan((frh(i) - 55.)/10.) + atan(55.))/3.1016) !print*,"fac=",xlons(i),frh(i), rh_dicycle_fct(i);call flush(6) end do end if !-- code to test the atan function ! do i = 1 ,100 !relative humidity ! y = 0.25 +0.75*(1.-(atan((float(i)-60.)/10.)+atan(50.))/3.1016)/0.9523154 ! print*,i,y ! enddo !print*,"FRH",maxval(frh),minval(frh),maxval(rh_dicycle_fct),minval(rh_dicycle_fct) !call flush(6) end subroutine rhControls! end subroutine rh_controls !------------------------------------------------------------------------------------ subroutine cupCloudLimits(name, ierrc, ierr, cap_inc, cap_max_in, heo_cup, heso_cup, qo_cup, qeso_cup, po & , po_cup, z_cup, heo, hkbo, qo, qeso, entr_rate_2d, hcot, k22, kbmax, klcl, kbcon & , ktop, depth_neg_buoy, frh, tpert, start_level_, use_excess, zqexec, ztexec & , x_add_buoy, xland, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupCloudLimits' ! Nome da subrotina real, parameter :: p_frh_crit_O = 0.7 real, parameter :: p_frh_crit_L = 0.7 !--- test 0.5 !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, use_excess integer, intent(in) :: kbmax(its:ite) integer, intent(in) :: start_level_(its:ite) real, intent(in) :: heo_cup(its:ite, kts:kte) real, intent(in) :: heso_cup(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: heo(its:ite, kts:kte) real, intent(in) :: qo_cup(its:ite, kts:kte) real, intent(in) :: qeso_cup(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: qeso(its:ite, kts:kte) real, intent(in) :: tpert(its:ite, kts:kte) real, intent(in) :: cap_max_in(its:ite) real, intent(in) :: cap_inc(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: zqexec(its:ite) real, intent(in) :: ztexec(its:ite) real, intent(in) :: x_add_buoy(its:ite) real, intent(in) :: entr_rate_2d(its:ite, kts:kte) character(len=*), intent(in) :: name integer, intent(inout) :: kbcon(its:ite) integer, intent(inout) :: ierr(its:ite) integer, intent(inout) :: ktop(its:ite) integer, intent(inout) :: klcl(its:ite) integer, intent(inout) :: k22(its:ite) real, intent(inout) :: hkbo(its:ite) real, intent(inout) :: depth_neg_buoy(its:ite) real, intent(inout) :: frh(its:ite) real, intent(inout) :: hcot(its:ite, kts:kte) character(len=128), intent(inout) :: ierrc(its:ite) !Local variables: integer :: i, k, k1, k2, kfinalzu integer, dimension(its:ite) :: start_level real :: delz_oversh !! height of cloud overshoot is 10% higher than the LNB. !! Typically it can 2 - 2.5km higher, but it depends on !!the severity of the thunderstorm. real, dimension(its:ite) :: cap_max real :: plus, hetest, dz, dbythresh, denom & , dzh, del_cap_max, fx, x_add, Z_overshoot, frh_crit real, dimension(kts:kte) :: dby delz_oversh = OVERSHOOT hcot = 0.0 dby = 0.0 start_level = 0 cap_max(:) = cap_max_in(:) do i = its, itf if (ierr(i) /= 0) cycle start_level(i) = start_level_(i) do k = kts, start_level(i) hcot(i, k) = hkbo(i) ! assumed no entraiment between these layers end do end do !--- determine the level of convective cloud base - kbcon !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON ! loop0: do i=its,itf !-default value kbcon (i)=kbmax(i)+3 depth_neg_buoy(i)=0. frh (i)=0. if(ierr(i) /= 0) cycle loop1: do while(ierr(i) == 0) kbcon(i)=start_level(i) do k=start_level(i)+1,KBMAX(i)+3 dz=z_cup(i,k)-z_cup(i,k-1) hcot(i,k)= ( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + entr_rate_2d(i,k-1)*dz *heo (i,k-1) ) / & (1.+0.5*entr_rate_2d(i,k-1)*dz) if(k==start_level(i)+1) then x_add = (c_xlv*zqexec(i)+c_cp*ztexec(i)) + x_add_buoy(i) hcot(i,k)= hcot(i,k) + x_add endif enddo loop2: do while (hcot(i,kbcon(i)) < HESO_cup(i,kbcon(i))) kbcon(i)=kbcon(i)+1 if(kbcon(i).gt.kbmax(i)+2) then ierr(i)=3 ierrc(i)="could not find reasonable kbcon in cup_kbcon : above kbmax+2 " exit loop2 endif !print*,"kbcon=",kbcon(i);call flush(6) enddo loop2 if(ierr(i) /= 0) cycle loop0 !--- cloud base pressure and max moist static energy pressure !--- i.e., the depth (in mb) of the layer of negative buoyancy depth_neg_buoy(i) = - (po_cup(i,kbcon(i))-po_cup(i,start_level(i))) if(MOIST_TRIGGER == 1) then frh(i)=0. dzh = 0 do k=k22(i),kbcon(i) dz = z_cup(i,k)-z_cup(i,max(k-1,kts)) frh(i) = frh(i) + dz*(qo(i,k)/qeso(i,k)) dzh = dzh + dz !print*,"frh=", k,dz,qo(i,k)/qeso(i,k) enddo frh(i) = frh(i)/(dzh+1.e-16) frh_crit =p_frh_crit_O*xland(i) + p_frh_crit_L*(1.-xland(i)) !fx = 4.*(frh(i) - frh_crit)* abs(frh(i) - frh_crit) !-quadratic fx = ((2./0.78)*exp(-(frh(i) - frh_crit)**2)*(frh(i) - frh_crit)) !- exponential fx = max(-1.,min(1.,fx)) del_cap_max = fx* cap_inc(i) cap_max(i) = min(max(cap_max_in(i) + del_cap_max, 10.),150.) !print*,"frh=", frh(i),kbcon(i),del_cap_max, cap_max(i)!, cap_max_in(i) endif !- test if the air parcel has enough energy to reach the positive buoyant region if(cap_max(i) >= depth_neg_buoy(i)) cycle loop0 !--- use this for just one search (original k22) ! if(cap_max(i) < depth_neg_buoy(i)) then ! ierr(i)=3 ! ierrc(i)="could not find reasonable kbcon in cup_cloud_limits" ! endif ! cycle loop0 !--- !- if am here -> kbcon not found for air parcels from k22 level k22(i)=k22(i)+1 !--- increase capmax !if(USE_MEMORY == 2000) cap_max(i)=cap_max(i)+cap_inc(i) !- get new hkbo x_add = (c_xlv*zqexec(i)+c_cp*ztexec(i)) + x_add_buoy(i) call getCloudBc(name,kts,kte,ktf,xland(i),po(i,kts:kte),heo_cup (i,kts:kte),hkbo (i),k22(i),x_add,Tpert(i,kts:kte)) ! start_level(i)=start_level(i)+1 ! hcot(i,start_level(i))=hkbo (i) enddo loop1 !--- last check for kbcon if(kbcon(i) == kts) then ierr(i)=33 ierrc(i)="could not find reasonable kbcon in cup_kbcon = kts" endif enddo loop0 !--- determine the level of neutral buoyancy - ktop do i = its, itf ktop(i) = ktf - 1 if (ierr(i) /= 0) cycle !~ dby(:)=0.0 start_level(i) = kbcon(i) do k = start_level(i) + 1, ktf - 1 dz = z_cup(i, k) - z_cup(i, k - 1) denom = 1.+0.5*entr_rate_2d(i, k - 1)*dz if (denom == 0.) then hcot(i, k) = hcot(i, k - 1) else hcot(i, k) = ((1.-0.5*entr_rate_2d(i, k - 1)*dz)*hcot(i, k - 1) + entr_rate_2d(i, k - 1)*dz*heo(i, k - 1))/denom end if end do do k = start_level(i) + 1, ktf - 1 if (hcot(i, k) < heso_cup(i, k)) then ktop(i) = k - 1 exit end if end do if (ktop(i) .le. kbcon(i) + 1) ierr(i) = 41 !---------------- if (OVERSHOOT > 1.e-6 .and. ierr(i) == 0) then Z_overshoot = (1.+delz_oversh)*z_cup(i, ktop(i)) do k = ktop(i), ktf - 2 if (Z_overshoot < z_cup(i, k)) then ktop(i) = min(k - 1, ktf - 2) exit end if end do end if end do end subroutine cupCloudLimits! end subroutine cup_cloud_limits !------------------------------------------------------------------------------------ subroutine cupMinimi(array, ks, kend, kt, ierr, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupMinimi' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: ks(its:ite) !! check-range integer, intent(in) :: kend(its:ite) !! check-range real, intent(in) :: array(its:ite, kts:kte) !! array input array integer, intent(out) :: kt(its:ite) !! kt output array of levels !Local variables: ! only local dimensions are need as of now in this routine integer :: i, k, kstop real, dimension(its:ite) :: x do i = its, itf kt(i) = ks(i) if (ierr(i) == 0) then x(i) = array(i, ks(i)) kstop = max(ks(i) + 1, kend(i)) ! do k = ks(i) + 1, kstop if (array(i, k) < x(i)) then x(i) = array(i, k) kt(i) = k end if end do end if end do end subroutine cupMinimi !end subroutine cup_MINIMI !------------------------------------------------------------------------------------ subroutine getInversionLayers(cumulus, ierr, psur, po_cup, to_cup, zo_cup, k_inv_layers, dtempdz, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getInversionLayers' ! Nome da subrotina integer, parameter :: p_extralayer = 0 !! makes plume top higher !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte real, intent(in) :: psur(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: to_cup(its:ite, kts:kte) real, intent(in) :: zo_cup(its:ite, kts:kte) character(len=*), intent(in) :: cumulus integer, intent(inout):: ierr(its:ite) integer, intent(out) :: k_inv_layers(its:ite, kts:kte) real, intent(out) :: dtempdz(its:ite, kts:kte) !Local variables: integer:: i, k, ilev, kk, k1, ix, k800, k550, ist integer :: local_k_inv_layers(its:ite, kts:kte) real :: dzm, delp, first_deriv(kts:kte), sec_deriv(kts:kte), distance(kts:kte) !-initialize k_inv_layers as 1 (non-existent layer)_ k_inv_layers = 1 !integer dtempdz = 0.0 first_deriv = 0.0 sec_deriv = 0.0 distance = 0.0 local_k_inv_layers = 1 ist = 3 do i = its, itf if (ierr(i) /= 0) cycle !- displacement from local surface pressure level delp = 1000.-psur(i) !- 2nd method ! DO k = kts+1,ktf-2 !dtempdz(i,k)= ( deriv3(zo_cup(i,k), zo_cup(i,kts:ktf), to_cup(i,kts:ktf), ktf-kts+1, 1,ierr(i))) !!! sec_deriv(k)=abs( deriv3(zo_cup(i,k), zo_cup(i,kts:ktf), to_cup(i,kts:ktf), ktf-kts+1, 2)) !print*,"2=",k,z_cup(i,k),dtempdz(i,k), ! ENDDO ! if(ierr(i) /= 0) cycle !-1st method !- get the 1st derivative do k = kts + ist, ktf - ist first_deriv(k) = (to_cup(i, k + 1) - to_cup(i, k - 1))/(zo_cup(i, k + 1) - zo_cup(i, k - 1)) end do first_deriv(kts:kts + ist - 1) = first_deriv(kts + ist) first_deriv(ktf - ist + 1:kte) = first_deriv(ktf - ist) dtempdz(i, :) = first_deriv(:) !- get the abs of the 2nd derivative do k = kts + ist + 1, ktf - ist - 1 sec_deriv(k) = abs((first_deriv(k + 1) - first_deriv(k - 1))/(zo_cup(i, k + 1) - zo_cup(i, k - 1))) end do sec_deriv(kts:kts + ist) = sec_deriv(kts + ist + 1) sec_deriv(ktf - ist:kte) = sec_deriv(ktf - ist - 1) ix = 1 do kk = kts + ist + 2, ktf - ist - 2 if (sec_deriv(kk) < sec_deriv(kk + 1) .and. sec_deriv(kk) < sec_deriv(kk - 1)) then local_k_inv_layers(i, ix) = kk ix = ix + 1 end if end do !- 2nd criteria do k = kts + ist + 2, ktf - ist - 2 kk = local_k_inv_layers(i, k) if (kk == 1) cycle if (dtempdz(i, kk) < dtempdz(i, kk - 1) .and. dtempdz(i, kk) < dtempdz(i, kk + 1)) then ! the layer is not a local maximum local_k_inv_layers(i, k) = 1 end if end do end do !- find the locations of inversions around 800 and 550 hPa do i = its, itf !---------------- !k_inv_layers(i,mid)=1 !---------------- if (ierr(i) /= 0) cycle !- displacement from local surface pressure level delp = 1000.-psur(i) !---------------- !k_inv_layers(i,mid)=21 !cycle !---------------- if (trim(cumulus) == 'shallow') then !- now find the closest layers of 800 and 550 hPa. !- this is for shallow convection k800 do k = kts, ktf distance(k) = abs(po_cup(i, local_k_inv_layers(i, k)) - (750.-delp)) end do k800 = minloc(abs(distance(kts:ktf)), 1) if (k800 <= kts .or. k800 >= ktf - 4) then k_inv_layers(i, p_shal) = ktf !ierr(i)=8 else !-save k800 in the k_inv_layers array k_inv_layers(i, p_shal) = local_k_inv_layers(i, k800) + p_extralayer end if !if( k_inv_layers(i,shal) <= kts .or. k_inv_layers(i,shal) >= ktf-4) then !print*,"SHAL_k_inv_layers=",k_inv_layers(i,shal),ierr(i) !ierr(i)=11 !endif elseif (trim(cumulus) == 'mid') then !- this is for mid/congestus convection k500 do k = kts, ktf distance(k) = abs(po_cup(i, local_k_inv_layers(i, k)) - (550.-delp)) end do k550 = minloc(abs(distance(kts:ktf)), 1) if (k550 <= kts .or. k550 >= ktf - 4) then k_inv_layers(i, p_mid) = 1 ierr(i) = 8 else !-save k550 in the k_inv_layers array k_inv_layers(i, p_mid) = local_k_inv_layers(i, k550) + p_extralayer end if if (k_inv_layers(i, p_mid) <= kts .or. k_inv_layers(i, p_mid) >= ktf - 4) then !print*,"MID_k_inv_layers=",k_inv_layers(i,MID),ierr(i) ierr(i) = 12 end if else k_inv_layers(i, :) = 1 ierr(i) = 88 end if end do contains function Deriv3(xx, xi, yi, ni, m, ierr) result(deriv3_out) !! Evaluate first- or second-order derivatives !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: ! ! Evaluate first- or second-order derivatives ! using three-point Lagrange interpolation ! written by: Alex Godunov (October 2009) !-------------------------------------------------------------------- ! input ... ! xx - the abscissa at which the interpolation is to be evaluated ! xi() - the arrays of data abscissas ! yi() - the arrays of data ordinates ! ni - size of the arrays xi() and yi() ! m - order of a derivative (1 or 2) ! output ... ! deriv3_out - interpolated value ! !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'Deriv3' ! Nome da função integer, parameter :: p_n = 3 !Variables (input): integer, intent(in):: ni, m real, intent(in):: xx real, intent(in) :: xi(ni) real, intent(in) :: yi(ni) !Local variables: real :: deriv3_out real:: x(p_n), f(p_n) integer i, j, k, ix integer, intent(inout) :: ierr ! exit if too high-order derivative was needed, if (m > 2) then deriv3_out = 0.0 return end if ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 if (xx < xi(1) .or. xx > xi(ni)) then deriv3_out = 0.0 ierr = 8 !stop "problem with 2nd derivative-deriv3 routine" return end if ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) i = 1 j = ni do while (j > i + 1) k = (i + j)/2 if (xx < xi(k)) then j = k else i = k end if end do ! shift i that will correspond to n-th order of interpolation ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... i = i + 1 - p_n/2 ! check boundaries: if i is ouside of the range [1, ... n] -> shift i if (i < 1) i = 1 if (i + p_n > ni) i = ni - p_n + 1 ! old output to test i ! write(*,100) xx, i ! 100 format (f10.5, I5) ! just wanted to use index i ix = i ! initialization of f(n) and x(n) do i = 1, p_n f(i) = yi(ix + i - 1) x(i) = xi(ix + i - 1) end do ! calculate the first-order derivative using Lagrange interpolation if (m == 1) then deriv3_out = (2.0*xx - (x(2) + x(3)))*f(1)/((x(1) - x(2))*(x(1) - x(3))) deriv3_out = deriv3_out+ (2.0*xx - (x(1) + x(3)))*f(2)/((x(2) - x(1))*(x(2) - x(3))) deriv3_out = deriv3_out+ (2.0*xx - (x(1) + x(2)))*f(3)/((x(3) - x(1))*(x(3) - x(2))) ! calculate the second-order derivative using Lagrange interpolation else deriv3_out = 2.0*f(1)/((x(1) - x(2))*(x(1) - x(3))) deriv3_out = deriv3_out+ 2.0*f(2)/((x(2) - x(1))*(x(2) - x(3))) deriv3_out = deriv3_out+ 2.0*f(3)/((x(3) - x(1))*(x(3) - x(2))) end if end function Deriv3 end subroutine getInversionLayers !------------------------------------------------------------------------------------- subroutine getZuZdPdf(cumulus, draft, ierr, kb, kt, zu, kts, kte, ktf, kpbli, k22, kbcon, klcl, po_cup, psur, xland, random) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getZuZdPdf' real, parameter :: p_px = 45./120. !! px sets the pressure level of max zu. its range is from 1 to 120. real, parameter :: p_px2 = 45./120. !! px sets the pressure level of max zu. its range is from 1 to 120. real, parameter :: p_beta_deep = 1.25, p_g_beta_deep = 0.8974707 !-------- gama pdf real, parameter, dimension(30) :: x_alpha = (/ & 3.699999, 3.699999, 3.699999, 3.699999, & 3.024999, 2.559999, 2.249999, 2.028571, 1.862500, & 1.733333, 1.630000, 1.545454, 1.475000, 1.415385, & 1.364286, 1.320000, 1.281250, 1.247059, 1.216667, & 1.189474, 1.165000, 1.142857, 1.122727, 1.104348, & 1.087500, 1.075000, 1.075000, 1.075000, 1.075000, & 1.075000/) real, parameter, dimension(30) :: g_alpha = (/ & 4.1706450, 4.1706450, 4.1706450, 4.1706450, & 2.0469250, 1.3878370, 1.1330030, 1.012418, 0.9494680, & 0.9153771, 0.8972442, 0.8885444, 0.8856795, 0.8865333, & 0.8897996, 0.8946404, 0.9005030, 0.9070138, 0.9139161, & 0.9210315, 0.9282347, 0.9354376, 0.9425780, 0.9496124, & 0.9565111, 0.9619183, 0.9619183, 0.9619183, 0.9619183, & 0.9619183/) !-------- gama pdf !Variables (input, output, inout) integer, intent(in) :: kts, kte, ktf, kpbli, k22, kbcon, kt, kb, klcl character(len=*), intent(in) :: draft character(len=*), intent(in) :: cumulus real, intent(in) :: po_cup(kts:kte) real, intent(in) :: psur real, intent(in) :: xland real, intent(in) :: random integer, intent(inout) :: ierr real, intent(inout) :: zu(kts:kte) !Local variables: integer :: kk, add, i, k, kb_adj, kpbli_adj, level_max_zu, ktarget integer:: itest !! 5=gamma+beta, 4=gamma, 1=beta integer:: minzu, maxzul, maxzuh, kstart integer :: nrec = 0 integer :: k1 real :: zumax, ztop_adj, a2, beta, alpha, kratio, tunning, fzu, krmax, dzudk, hei_updf, hei_down real :: lev_start, g_alpha2, g_a, y1, x1, g_b, a, b, alpha2, csum, zubeg, wgty, dp_layer, slope real :: zuh(kts:kte), zul(kts:kte) real :: pmaxzu !! pressure height of max zu for deep logical :: do_smooth DO_SMOOTH = .false. if (USE_SMOOTH_PROF == 1) DO_SMOOTH = .true. !-- fill zu with zeros itest = -999 zu = 0.0 zuh = 0.0 zul = 0.0 if (trim(draft) == "deep_up") itest = CUM_ZUFORM(p_deep) !ocean/land if (trim(draft) == "mid_up") itest = CUM_ZUFORM(p_mid) !--------------------------------------------------------- if (itest == 5 .and. trim(draft) == "mid_up") then !--- part 1 GAMMA format csum = 0. zubeg = 0. lev_start = min(.9, .1 + csum*.013) kb_adj = max(kb, 2) kb_adj = min(kb_adj, kt - 1) if (kb_adj == kt) stop "kb_adj==kt" tunning = 0.30 alpha2 = (tunning*(p_beta_deep - 2.) + 1.)/(1.-tunning) do k = 27, 3, -1 if (x_alpha(k) >= alpha2) exit end do k1 = k + 1 if (x_alpha(k1) .ne. x_alpha(k1 - 1)) then a = x_alpha(k1) - x_alpha(k1 - 1) b = x_alpha(k1 - 1)*(k1) - (k1 - 1)*x_alpha(k1) x1 = (alpha2 - b)/a y1 = a*x1 + b g_a = g_alpha(k1) - g_alpha(k1 - 1) g_b = g_alpha(k1 - 1)*k1 - (k1 - 1)*g_alpha(k1) g_alpha2 = g_a*x1 + g_b else g_alpha2 = g_alpha(k1) end if fzu = GammaBrams(alpha2 + p_beta_deep)/(g_alpha2*p_g_beta_deep) fzu = 0.01*fzu do k = kb_adj, min(kte, kt) kratio = (po_cup(k) - po_cup(kb_adj))/(po_cup(kt) - po_cup(kb_adj)) zu(k) = zubeg + fzu*kratio**(alpha2 - 1.0)*(1.0 - kratio)**(p_beta_deep - 1.0) end do !- normalize ZU zu(kts:min(kte, kt + 1)) = zu(kts:min(kte, kt + 1))/(1.e-12 + maxval(zu(kts:min(kte, kt + 1)))) !--- part 2: BETA format pmaxzu = psur - p_px*(psur - po_cup(kt)) kb_adj = minloc(abs(po_cup(kts:kt) - pmaxzu), 1) kb_adj = max(kb, kb_adj) kb_adj = min(kb_adj, kt) !beta=4. !=> must be larger than 1 !=> higher makes the profile sharper !=> around the maximum zu !- 2nd approach for beta and alpha parameters !- the tunning parameter must be between 0.5 (low level max zu) !- and 1.5 (high level max zu) !tunning= 1.0 tunning = 0.6 ! beta = 2.0/tunning alpha = tunning*beta ! !- this alpha constrains the location of the maximun ZU to be at !- "kb_adj" vertical level alpha = 1.+(beta - 1.0)*(float(kb_adj)/float(kt + 1))/(1.0 - (float(kb_adj)/float(kt + 1))) ! ! imposing zu(ktop) = 0 do k = klcl - 1, min(kte, kt) kratio = float(k)/float(kt + 1) zuh(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) end do !- normalize ZU zuh(kts:min(kte, kt + 1)) = zuh(kts:min(kte, kt + 1))/(1.e-12 + maxval(zuh(kts:min(kte, kt + 1)))) !--- part 3: BETA format from sfc to max zuh, then GAMMA format do k = kts, max(kts, maxloc(zuh(:), 1) - 2) zu(k) = zuh(k) end do do k = max(kts, maxloc(zuh(:), 1) - 1), min(maxloc(zuh(:), 1) + 1, kt) zu(k) = 0.5*(zu(k) + zuh(k)) end do !-- special treatment below k22/klcl do k = klcl, kts + 1, -1 zu(k) = zu(k + 1)*0.5 end do !-- smooth section if (do_smooth) then !--from surface zul(kts + 1) = zu(kts + 1)*0.25 do k = kts + 2, maxloc(zu, 1) zul(k) = (zu(k - 1) + zu(k))*0.5 end do do k = kts + 1, maxloc(zu, 1) zu(k) = (zul(k) + zu(k))*0.5 end do !--from ktop zul(kt - 1) = zu(kt - 1)*0.1 !print*,"ZUMD=",kt,zu(kt),zul(kt) do k = kt - 2, max(kt - min(maxloc(zu, 1), 5), kts), -1 zul(k) = (zul(k + 1) + zu(k))*0.5 end do wgty = 0. do k = kt, max(kt - min(maxloc(zu, 1), 5), kts), -1 wgty = wgty + 1./(float(min(maxloc(zu, 1), 5)) + 1) zu(k) = zul(k)*(1.-wgty) + zu(k)*wgty !print*,"zuMD=",k,zu(k),zul(k),(zul(k)+zu(k))*0.5,min(maxloc(zu,1),5),wgty end do end if zu(kts) = 0. !--------------------------------------------------------- elseif (itest == 20) then !--- land/ocean hei_updf = (1.-xland)*hei_updf_land + xland*hei_updf_ocean !- add a randomic perturbation hei_updf = hei_updf + random !- for gate soundings !hei_updf = max(0.1, min(1.,float(JL)/100.)) !beta =1.0+float(JL)/100. * 5. !--hei_updf parameter goes from 0 to 1 = rainfall decreases with hei_updf pmaxzu = (psur - 100.)*(1.-0.5*hei_updf) + 0.6*(po_cup(kt))*0.5*hei_updf !- beta parameter: must be larger than 1, higher makes the profile sharper around the maximum zu !beta = max(1.1, 2.1 - 0.5*hei_updf) beta = 2.2 kb_adj = minloc(abs(po_cup(kts:kt) - pmaxzu), 1) kb_adj = max(kb, kb_adj) kb_adj = min(kb_adj, kt) !- this alpha constrains the location of the maximun ZU to be at "kb_adj" vertical level alpha = 1.+(beta - 1.0)*(float(kb_adj)/float(kt + 1))/(1.0 - (float(kb_adj)/float(kt + 1))) ! do k = klcl - 1, min(kte, kt) kratio = float(k)/float(kt + 1) zu(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) end do !-- special treatment below k22/klcl do k = klcl, kts + 1, -1 zu(k) = zu(k + 1)*0.5 end do !if(use_linear_subcl_mf == 1) then ! zu(kts)=0. ! kstart=kbcon ! slope=(zu(kstart)-zu(kts))/(po_cup(kstart)-po_cup(kts) + 1.e-6) ! do k=kstart-1,kts+1,-1 ! zu(k) = zu(kstart)-slope*(po_cup(kstart)-po_cup(k)) ! !print*,"k=",zu(kstart),zu(k),zu(kts) ! enddo ! go to 333 ! endif !-- smooth section if (do_smooth) then !--from surface zul(kts + 1) = zu(kts + 1)*0.25 do k = kts + 2, maxloc(zu, 1) zul(k) = zu(k - 1)*0.8 + zu(k)*0.2 end do do k = kts + 1, maxloc(zu, 1) zu(k) = (zul(k) + zu(k))*0.5 end do !--from ktop zul(kt) = zu(kt)*0.1 do k = kt - 1, max(kt - min(maxloc(zu, 1), 5), kts), -1 zul(k) = (zul(k + 1) + zu(k))*0.5 end do wgty = 0.0 do k = kt, max(kt - min(maxloc(zu, 1), 5), kts), -1 wgty = wgty + 1./(float(min(maxloc(zu, 1), 5)) + 1) zu(k) = zul(k)*(1.-wgty) + zu(k)*wgty end do end if zu(kts) = 0. !333 continue !--------------------------------------------------------- elseif (itest == 10) then if (xland < 0.90) then !- over land hei_updf = hei_updf_land else hei_updf = hei_updf_ocean end if !- for gate soundings !if(gate) hei_updf = max(0.1, min(1.,float(JL)/100.)) !print*,"JL=",jl,hei_updf pmaxzu = 780. kb_adj = minloc(abs(po_cup(kts:kt) - pmaxzu), 1)!;print*,"1=",kb_adj,po_cup(kb_adj) kb_adj = max(kb, kb_adj) kb_adj = min(kb_adj, kt) beta = 5.0 !- this alpha constrains the location of the maximun ZU to be at "kb_adj" vertical level alpha = 1.+(beta - 1.0)*(float(kb_adj)/float(kt + 1))/(1.0 - (float(kb_adj)/float(kt + 1))) do k = klcl - 1, min(kte, kt) kratio = float(k)/float(kt + 1) zul(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) !print*,"1",k,zul(k),kb_adj,pmaxzu end do zul(kts:min(kte, kt)) = zul(kts:min(kte, kt))/(1.e-9 + maxval(zul(kts:min(kte, kt)), 1)) !----------- pmaxzu = po_cup(kt) + 300. kb_adj = minloc(abs(po_cup(kts:kt) - pmaxzu), 1) kb_adj = max(kb, kb_adj) kb_adj = min(kb_adj, kt) beta = 1.5 !- this alpha constrains the location of the maximun ZU to be at "kb_adj" vertical level alpha = 1.+(beta - 1.0)*(float(kb_adj)/float(kt + 1))/(1.0 - (float(kb_adj)/float(kt + 1))) do k = klcl - 1, min(kte, kt) kratio = float(k)/float(kt + 1) zuh(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) end do zuh(kts:min(kte, kt)) = zuh(kts:min(kte, kt))/(1.e-9 + maxval(zuh(kts:min(kte, kt)), 1)) !increasing contribuition of zuh => more heating at upper levels/less precip zu(:) = (1.-hei_updf)*zul(:) + hei_updf*zuh(:) !-- special treatment below k22/klcl do k = klcl, kts + 1, -1 zu(k) = zu(k + 1)*0.5 end do !-- smooth section if (do_smooth) then !--from surface zul(kts + 1) = zu(kts + 1)*0.25 do k = kts + 2, maxloc(zu, 1) zul(k) = zu(k - 1)*0.8 + zu(k)*0.2 end do do k = kts + 1, maxloc(zu, 1) zu(k) = (zul(k) + zu(k))*0.5 end do !--from ktop zul(kt) = zu(kt)*0.1 do k = kt - 1, max(kt - min(maxloc(zu, 1), 5), kts), -1 zul(k) = (zul(k + 1) + zu(k))*0.5 end do wgty = 0. do k = kt, max(kt - min(maxloc(zu, 1), 5), kts), -1 wgty = wgty + 1./(float(min(maxloc(zu, 1), 5)) + 1) zu(k) = zul(k)*(1.-wgty) + zu(k)*wgty !print*,"zu=",k,zu(k),zul(k),(zul(k)+zu(k))*0.5,min(maxloc(zu,1),5),wgty end do end if zu(kts) = 0. !--------------------------------------------------------- elseif (trim(draft) == "shallow_up") then kb_adj = kts ! level where mass flux starts kpbli_adj = kpbli if (kpbli_adj < kb_adj .or. kpbli_adj >= kt) then kpbli_adj = kb_adj + 1 end if !- location of the maximum Zu: dp_layer mbar above PBL height !dp_layer = 10. !mbar !level_max_zu = minloc(abs(po_cup(kts:kt+1)-(po_cup(kpbli_adj)-dp_layer)),1) ! k1 = max(kbcon, kpbli_adj) !- location of the maximum Zu: dp_layer mbar above k1 height hei_updf = (1.-xland)*hei_updf_land + xland*hei_updf_ocean !hei_updf = (float(JL)-20)/40. ; print*,"JL=",jl,hei_updf dp_layer = hei_updf*(po_cup(k1) - po_cup(kt)) level_max_zu = minloc(abs(po_cup(kts:kt + 1) - (po_cup(k1) - dp_layer)), 1) level_max_zu = min(level_max_zu, kt - 1) level_max_zu = max(level_max_zu, kts + 1) krmax = float(level_max_zu)/float(kt + 1) krmax = min(krmax, 0.99) beta = BETA_SH!smaller => sharper detrainment layer !beta= ((1.-xland)*0.43 +xland)*beta_sh !beta= 3.0!smaller => sharper detrainment layer !beta = 1.+4.*(float(JL))/40. !- this alpha imposes the maximum zu at kpbli alpha = 1.+krmax*(beta - 1.)/(1.-krmax) !alpha=min(6.,alpha) !- to check if dZu/dk = 0 at k=kpbli_adj !kratio=krmax !dzudk=(alpha-1.)*(kratio**(alpha-2.)) * (1.-kratio)**(beta-1.) - & ! (kratio**(alpha-1.))*((1.-kratio)**(beta-2.))*(beta-1.) !- Beta PDF do k = kts + 1, min(kte, kt) kratio = float(k)/float(kt + 1) zu(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) end do zu(kts) = 0. ! !-- special treatment below kbcon - linear Zu if (USE_LINEAR_SUBCL_MF == 1) then kstart = kbcon slope = (zu(kstart) - zu(kts))/(po_cup(kstart) - po_cup(kts) + 1.e-6) do k = kstart - 1, kts + 1, -1 zu(k) = zu(kstart) - slope*(po_cup(kstart) - po_cup(k)) !print*,"k=",zu(kstart),zu(k),zu(kts) end do end if !-- special treatment below kclcl !do k=(klcl-1),kts+1,-1 ! zu(k)=zu(k+1)*0.5 !enddo ! !-- smooth section !IF( .not. do_smooth) then ! zul(kts+1)=zu(kts+1)*0.1 ! do k=kts+2,maxloc(zu,1) ! zul(k)=(zu(k-1)+zu(k))*0.5 ! enddo ! do k=kts+1,maxloc(zu,1) ! zu(k)=(zul(k)+zu(k))*0.5 ! enddo !ENDIF !zu(kts)=0. !--------------------------------------------------------- elseif (trim(draft) == "DOWN") then if (trim(cumulus) == 'shallow') return if (trim(cumulus) == 'mid') beta = 2.5 if (trim(cumulus) == 'deep') beta = 2.5 hei_down = (1.-xland)*hei_down_land + xland*hei_down_ocean pmaxzu = hei_down*po_cup(kt) + (1.-hei_down)*psur kb_adj = minloc(abs(po_cup(kts:kt) - pmaxzu), 1) !- this alpha constrains the location of the maximun ZU to be at "kb_adj" vertical level alpha = 1.+(beta - 1.0)*(float(kb_adj)/float(kt + 1))/(1.0 - (float(kb_adj)/float(kt + 1))) do k = kts + 1, min(kt + 1, ktf) kratio = float(k)/float(kt + 1) zu(k) = kratio**(alpha - 1.0)*(1.0 - kratio)**(beta - 1.0) end do !-- smooth section if (do_smooth) then zul(kts + 1) = zu(kts + 1)*0.1 wgty = 0. do k = kts + 2, maxloc(zu, 1) wgty = wgty + 1./(float(max(2, maxloc(zu, 1))) - 1.) wgty = 0.5 !print*,"zD1=",k,zu(k),zul(k-1),wgty,zul(k-1)*(1.-wgty)+ zu(k)*wgty zul(k) = zul(k - 1)*(1.-wgty) + zu(k)*wgty end do wgty = 0. do k = kts + 1, maxloc(zu, 1) wgty = wgty + 1./(float(max(2, maxloc(zu, 1))) - 1.) wgty = 0.5 !print*,"zD2=",k,zu(k),zul(k),wgty,zul(k)*(1.-wgty)+ zu(k)*wgty zu(k) = zul(k)*(1.-wgty) + zu(k)*wgty end do end if zu(kts) = 0. end if if (maxval(zu(kts:min(kte, kt + 1)), 1) <= 0.0) then zu = 0.0 ierr = 51 !ierr(i)=51 else !- normalize ZU zu(kts:min(kte, kt + 1)) = zu(kts:min(kte, kt + 1))/(1.e-9 + maxval(zu(kts:min(kte, kt + 1)), 1)) end if end subroutine getZuZdPdf !------------------------------------------------------------------------------------ subroutine getLateralMassFlux(itf, ktf, its, ite, kts, kte, min_entr_rate, ierr, ktop, zo_cup, zuo, cd, entr_rate_2d, po_cup & , up_massentro, up_massdetro, up_massentr, up_massdetr, draft, kbcon, k22, kpbl, up_massentru & , up_massdetru, lambau) !! brief !! !! @note !! !! **Project**: project_name !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getLateralMassFlux' ! Nome da subrotina integer, parameter :: p_mass_u_option = 1 integer, parameter :: p_smooth_depth = 2 !! increasing this parameter, !! strongly damps the heat/drying rates, precip ... !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: kpbl(its:ite) real, intent(in) :: min_entr_rate real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: zuo(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in), optional :: lambau(its:ite) character(len=*), intent(in) :: draft real, intent(inout) :: cd(its:ite, kts:kte) real, intent(inout) :: entr_rate_2d(its:ite, kts:kte) real, intent(out) :: up_massentro(its:ite, kts:kte) real, intent(out) :: up_massdetro(its:ite, kts:kte) real, intent(out) :: up_massentr(its:ite, kts:kte) real, intent(out) :: up_massdetr(its:ite, kts:kte) real, intent(out), optional :: up_massentru(its:ite, kts:kte) real, intent(out), optional :: up_massdetru(its:ite, kts:kte) !Local variables: integer :: i, k, turn, ismooth1, ismooth2, nlay, k_ent real :: dz, mass1, mass2, dp, rho, zuo_ave logical :: smooth integer :: incr1 = 1 integer :: incr2 = 1 smooth = .false. if (USE_SMOOTH_PROF == 1) smooth = .true. up_massentro(:, :) = 0. up_massdetro(:, :) = 0. if (present(up_massentru) .and. present(up_massdetru)) then up_massentru(:, :) = 0. up_massdetru(:, :) = 0. end if nlay = int(kte/90) do i = its, itf if (ierr(i) /= 0) cycle !-will not allow detrainment below the location of the maximum zu ! if(draft=='shallow'.or.draft == 'mid') cd(i,1:maxloc(zuo(i,:),1)-2)=0.0 !-will not allow detrainment below cloud base or in the PBL if (draft == 'shallow') then cd(i, 1:max(kbcon(i), kpbl(i)) + nlay) = 0.0 else cd(i, 1:maxloc(zuo(i, :), 1) + nlay) = 0.0 end if !- mass entrainment and detrainment are defined on model levels do k = kts, maxloc(zuo(i, :), 1) !=> below location of maximum value zu -> change entrainment dz = zo_cup(i, k + 1) - zo_cup(i, k) zuo_ave = 0.5*(zuo(i, k + 1) + zuo(i, k)) up_massdetro(i, k) = cd(i, k)*dz*zuo_ave up_massentro(i, k) = zuo(i, k + 1) - zuo(i, k) + up_massdetro(i, k) up_massentro(i, k) = max(up_massentro(i, k), min_entr_rate*dz*zuo_ave) !-- check dd_massdetro in case of dd_massentro has been changed above up_massdetro(i, k) = -zuo(i, k + 1) + zuo(i, k) + up_massentro(i, k) !if(zuo(i,k-1).gt.0.) then cd(i, k) = up_massdetro(i, k)/(dz*zuo_ave) entr_rate_2d(i, k) = up_massentro(i, k)/(dz*zuo_ave) !endif !if(draft=='shallow')print*,"ent1=",k,real(entr_rate_2d(i,k),4)!,real((min(zo_cup(i,k_ent)/zo_cup(i,k-1),1.))) end do !--- limit the effective entrainment rate k_ent = maxloc(zuo(i, :), 1) do k = k_ent + 1, ktop(i) - 1 entr_rate_2d(i, k) = entr_rate_2d(i, k_ent)*(min(zo_cup(i, k_ent)/zo_cup(i, k), 1.)) entr_rate_2d(i, k) = max(min_entr_rate, entr_rate_2d(i, k)) !if(draft=='shallow')print*,"ent2=",k,real(entr_rate_2d(i,k),4),real((min(zo_cup(i,k_ent)/zo_cup(i,k),1.))) end do entr_rate_2d(i, ktop(i):kte) = 0. !================= if (smooth .and. trim(draft) /= 'shallow') then !---smoothing the transition zone (from maxloc(zu)-1 to maxloc(zu)+1) ismooth1 = max(kts + 2, maxloc(zuo(i, :), 1) - p_smooth_depth) ismooth2 = min(ktf - 2, maxloc(zuo(i, :), 1) + p_smooth_depth) !if(draft == 'shallow') ismooth1 = max(ismooth1,max(kbcon(i),kpbl(i))+nlay)+1 do k = ismooth1, ismooth2 dz = zo_cup(i, k + 1) - zo_cup(i, k) zuo_ave = 0.5*(zuo(i, k + 1) + zuo(i, k)) up_massentro(i, k) = 0.5*(entr_rate_2d(i, k)*dz*zuo_ave + up_massentro(i, k - 1)) up_massdetro(i, k) = zuo(i, k) + up_massentro(i, k) - zuo(i, k + 1) if (up_massdetro(i, k) .lt. 0.) then up_massdetro(i, k) = 0. up_massentro(i, k) = zuo(i, k + 1) - zuo(i, k) entr_rate_2d(i, k) = (up_massentro(i, k))/(dz*zuo_ave) endif if(zuo_ave > 0.) & cd(i,k)=up_massdetro(i,k)/(dz*zuo_ave) end do do k = ismooth1, ismooth2 dz = zo_cup(i, k + 1) - zo_cup(i, k) zuo_ave = 0.5*(zuo(i, k + 1) + zuo(i, k)) up_massdetro(i, k) = 0.5*(cd(i, k)*dz*zuo_ave + up_massdetro(i, k - 1)) up_massentro(i, k) = zuo(i, k + 1) - zuo(i, k) + up_massdetro(i, k) if (up_massentro(i, k) .lt. 0.) then up_massentro(i, k) = 0. up_massdetro(i, k) = zuo(i, k) - zuo(i, k + 1) cd(i, k) = up_massdetro(i, k)/(dz*zuo_ave) end if if (zuo_ave > 0.) & entr_rate_2d(i, k) = (up_massentro(i, k))/(dz*zuo_ave) end do !-----end of the transition zone end if !================= do k = maxloc(zuo(i, :), 1) + incr1, ktop(i) !=> above location of maximum value zu -> change detrainment dz = zo_cup(i, k + 1) - zo_cup(i, k) zuo_ave = 0.5*(zuo(i, k + 1) + zuo(i, k)) up_massentro(i, k) = entr_rate_2d(i, k)*dz*zuo_ave up_massdetro(i, k) = zuo(i, k) + up_massentro(i, k) - zuo(i, k + 1) up_massdetro(i, k) = max(up_massdetro(i, k), 0.0) !-- check up_massentro in case of dd_up_massdetro has been changed above up_massentro(i, k) = -zuo(i, k) + up_massdetro(i, k) + zuo(i, k + 1) if (zuo_ave .gt. 0.) then cd(i, k) = up_massdetro(i, k)/(dz*zuo_ave) entr_rate_2d(i, k) = up_massentro(i, k)/(dz*zuo_ave) end if end do do k = kts, kte up_massentr(i, k) = up_massentro(i, k) up_massdetr(i, k) = up_massdetro(i, k) end do if (present(up_massentru) .and. present(up_massdetru)) then if (p_mass_u_option == 1) then do k = kts + 1, kte !-- for weaker mixing up_massentru(i, k - 1) = up_massentro(i, k - 1) + lambau(i)*up_massdetro(i, k - 1) up_massdetru(i, k - 1) = up_massdetro(i, k - 1) + lambau(i)*up_massdetro(i, k - 1) !-- for stronger mixing ! up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massentro(i,k-1) ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massentro(i,k-1) end do else turn = maxloc(zuo(i, :), 1) do k = kts + 1, turn up_massentru(i, k - 1) = up_massentro(i, k - 1) + lambau(i)*up_massentro(i, k - 1) up_massdetru(i, k - 1) = up_massdetro(i, k - 1) + lambau(i)*up_massentro(i, k - 1) end do do k = turn + 1, kte up_massentru(i, k - 1) = up_massentro(i, k - 1) + lambau(i)*up_massdetro(i, k - 1) up_massdetru(i, k - 1) = up_massdetro(i, k - 1) + lambau(i)*up_massdetro(i, k - 1) end do end if end if do k = ktop(i) + 1, kte cd(i, k) = 0. entr_rate_2d(i, k) = 0. end do end do ! i !---- check mass conservation do i = its, itf if (ierr(i) /= 0) cycle do k = kts + 1, kte dz = zo_cup(i, k) - zo_cup(i, k - 1) dp = 100*(po_cup(i, k) - po_cup(i, k - 1)) rho = -dp/dz/c_grav mass1 = (zuo(i, k) - zuo(i, k - 1)) - up_massentro(i, k - 1) + up_massdetro(i, k - 1) !print*,"masscons=",mass1!,-rho*g*(zuo(i,k)-zuo(i,k-1))/dp, (zuo(i,k)-zuo(i,k-1))/dz,( up_massentro(i,k-1)-up_massdetro(i,k-1))/dz,rho mass2 = (zuo(i, k) - zuo(i, k - 1)) - up_massentru(i, k - 1) + up_massdetru(i, k - 1) end do end do end subroutine getLateralMassFlux !------------------------------------------------------------------------------------ subroutine getBuoyancy(itf, ktf, its, ite, kts, kte, ierr, klcl, kbcon, ktop, hc, he_cup, hes_cup, dby, z_cup) !! brief !! !! @note !! !! **Project**: project_name !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getBuoyancy' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: hc(its:ite, kts:kte) real, intent(in) :: he_cup(its:ite, kts:kte) real, intent(in) :: hes_cup(its:ite, kts:kte) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(out) :: dby(its:ite, kts:kte) !Local variables: integer :: i, k do i = its, itf dby(i, :) = 0. if (ierr(i) /= 0) cycle do k = kts, klcl(i) dby(i, k) = hc(i, k) - he_cup(i, k) end do do k = klcl(i) + 1, ktop(i) + 1 dby(i, k) = hc(i, k) - hes_cup(i, k) end do end do end subroutine getBuoyancy !------------------------------------------------------------------------------------ subroutine cupUpMoistureLight(name, start_level, klcl, ierr, ierrc, z_cup, qc, qrc, pw, pwav, hc, tempc, xland, po, p_cup & , kbcon, ktop, cd, dby, clw_all, t_cup, q_env, gamma_cup, zu, qes_cup, k22, qe_cup, zqexec & , use_excess, rho, up_massentr, up_massdetr, psum, psumh, c1d, x_add_buoy, itest, itf, ktf, ipr & , jpr, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpMoistureLight' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: use_excess, itest, itf, ktf, its, ite, ipr, jpr, kts, kte integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: start_level(its:ite) character(len=*), intent(in) :: name real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: p_cup(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: q_env(its:ite, kts:kte) !! environmental q on model levels real, intent(in) :: zu(its:ite, kts:kte) !! normalized updraft mass flux real, intent(in) :: gamma_cup(its:ite, kts:kte) !! gamma on model cloud levels real, intent(in) :: qe_cup(its:ite, kts:kte) !! environmental q on model cloud levels real, intent(in) :: hc(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: up_massentr(its:ite, kts:kte) real, intent(in) :: up_massdetr(its:ite, kts:kte) real, intent(in) :: dby(its:ite, kts:kte) !! buoancy term real, intent(in) :: qes_cup(its:ite, kts:kte) !! saturation q on model cloud levels real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: cd(its:ite, kts:kte) !! detrainment function real, intent(in) :: c1d(its:ite, kts:kte) real, intent(in) :: zqexec(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: x_add_buoy(its:ite) integer, intent(inout) :: ierr(its:ite) !! ierr error value, maybe modified in this routine character(len=128), intent(inout) :: ierrc(its:ite) real, intent(out) :: qc(its:ite, kts:kte) !! cloud q (including liquid water) after entrainment real, intent(out) :: qrc(its:ite, kts:kte) !! liquid water content in cloud after rainout real, intent(out) :: pw(its:ite, kts:kte) !! condensate that will fall out at that level real, intent(out) :: clw_all(its:ite, kts:kte) real, intent(out) :: tempc(its:ite, kts:kte) real, intent(out) :: pwav(its:ite) !! totan normalized integrated condensate (I1) real, intent(out) :: psum(its:ite) real, intent(out) :: psumh(its:ite) !Local variables: integer :: iounit, iprop, i, k, k1, k2, n, nsteps, delt, tem1 real :: dp, rhoc, dh, dz, radius, berryc0, q1, berryc real :: qaver, denom, aux, cx0, qrci, step, cbf, qrc_crit_bf, min_liq, qavail, delt_hc_glac real :: qrch !! saturation q in cloud !!--- no precip for small clouds !if(name.eq.'shallow') c0 = C0_SHAL !if(name.eq.'mid' ) c0 = C0_MID !if(name.eq.'deep' ) c0 = C0_DEEP do i = its, itf pwav(i) = 0. psum(i) = 0. psumh(i) = 0. end do do k = kts, ktf do i = its, itf pw(i, k) = 0. qrc(i, k) = 0. clw_all(i, k) = 0. tempc(i, k) = t_cup(i, k) qc(i, k) = qe_cup(i, k) end do end do !--- get boundary condition for qc do i = its, itf if (ierr(i) /= 0) cycle call getCloudBc(name, kts, kte, ktf, xland(i), po(i, kts:kte), qe_cup(i, kts:kte), qaver, k22(i)) qc(i, kts:start_level(i)) = qaver + zqexec(i) + 0.5*x_add_buoy(i)/real(c_xlv) end do do i = its, itf if (ierr(i) /= 0) cycle do k = start_level(i) + 1, ktop(i) + 1 dz = z_cup(i, k) - z_cup(i, k - 1) ! !--- saturation in cloud, this is what is allowed to be in it ! qrch = qes_cup(i, k) + (1./real(c_xlv))*(gamma_cup(i, k)/(1.+gamma_cup(i, k)))*dby(i, k) !- 1. steady state plume equation, for what could !- be in cloud without condensation denom = (zu(i, k - 1) - .5*up_massdetr(i, k - 1) + up_massentr(i, k - 1)) if (denom > 0.) then qc(i, k) = (qc(i, k - 1)*zu(i, k - 1) - .5*up_massdetr(i, k - 1)*qc(i, k - 1) + up_massentr(i, k - 1) & * q_env(i, k - 1))/denom if (k == start_level(i) + 1) qc(i, k) = qc(i, k) + (zqexec(i) + 0.5*x_add_buoy(i)/real(c_xlv)) & * up_massentr(i, k - 1)/denom else qc(i, k) = qc(i, k - 1) end if !--- total condensed water before rainout clw_all(i, k) = max(0., qc(i, k) - qrch) !--- updraft temp tempc(i, k) = (1./real(c_cp))*(hc(i, k) - c_grav*z_cup(i, k) - real(c_xlv)*qrch) !--add glaciation effect on the MSE if (p_melt_glac) then delt_hc_glac = clw_all(i, k)*(1.-FractLiqF(tempc(i, k)))*c_xlf tempc(i, k) = tempc(i, k) + (1./real(c_cp))*delt_hc_glac end if cx0 = (c1d(i, k) + c0)*dz if (c0 < 1.e-6) cx0 = 0. qrc(i, k) = clw_all(i, k)/(1.+cx0) pw(i, k) = cx0*max(0., qrc(i, k) - QRC_CRIT)! units kg[rain]/kg[air] !--- convert pw to normalized pw pw(i, k) = pw(i, k)*zu(i, k) !- total water (vapor + condensed) in updraft after the rainout qc(i, k) = qrc(i, k) + min(qc(i, k), qrch) end do end do !- get back water vapor qc do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) + 1 qc(i, k) = qc(i, k) - qrc(i, k) end do end do end subroutine cupUpMoistureLight !------------------------------------------------------------------------------------ subroutine cupUpVVel(vvel2d, vvel1d, zws, entr_rate_2d, cd, z, z_cup, zu, dby, GAMMA_CUP, t_cup, tempco, qco, qrco, qo & , start_level, klcl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte, wlpool, wlpool_bcon, task) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpVVel' integer, parameter :: p_n_smooth = 1 real, parameter :: p_ctea = 1./3. real, parameter :: p_cteb = 2. real, parameter :: p_visc = 2000. real, parameter :: p_eps = 0.622 real, parameter :: p_f = 2., p_c_d = 0.506, p_gam = 0.5, p_beta = 1.875 !,ftun1=0.5, ftun2=0.8 logical, parameter :: p_smooth = .true. !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, task integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: start_level(its:ite) real, intent(in) :: z(its:ite, kts:kte) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: zu(its:ite, kts:kte) real, intent(in) :: gamma_cup(its:ite, kts:kte) real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: dby(its:ite, kts:kte) real, intent(in) :: entr_rate_2d(its:ite, kts:kte) real, intent(in) :: cd(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) real, intent(in) :: qco(its:ite, kts:kte) real, intent(in) :: qrco(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: zws(its:ite) integer, intent(inout) :: ierr(its:ite) real, intent(inout) :: wlpool(its:ite) real, intent(inout) :: wlpool_bcon(its:ite) real, intent(out) :: vvel2d(its:ite, kts:kte) real, intent(out) :: vvel1d(its:ite) !Local variables: integer :: i, k, k1, nvs real :: dz, bu, dw2, dw1, kx, dz1m, tv, tve, vs, ftun1, ftun2, ke ftun1 = 0.25 ftun2 = 1. if (task == 1) then do i = its, itf !-- initialize arrays to zero. vvel1d(i) = 0.0 vvel2d(i, :) = 0.0 if (ierr(i) /= 0) cycle vvel2d(i, kts:kbcon(i)) = max(1., max(wlpool_bcon(i)**2, zws(i)**2)) loop0: do k = kbcon(i), ktop(i) dz = z_cup(i, k + 1) - z_cup(i, k) tve = 0.5*(t_cup(i, k)*(1.+(qo(i, k)/p_eps)/(1.+qo(i, k))) & + t_cup(i, k + 1)*(1.+(qo(i, k + 1)/p_eps)/(1.+qo(i, k + 1)))) tv = 0.5*(tempco(i, k)*(1.+(qco(i, k)/p_eps)/(1.+qco(i, k))) & + tempco(i, k + 1)*(1.+(qco(i, k + 1)/p_eps)/(1.+qco(i, k + 1)))) bu = c_grav*((tv - tve)/tve - ftun2*0.50*(qrco(i, k + 1) + qrco(i, k))) dw1 = 2./(p_f*(1.+p_gam))*bu*dz kx = (1.+p_beta*p_c_d)*max(entr_rate_2d(i, k), cd(i, k))*dz*ftun1 dw2 = (vvel2d(i, k)) - 2.*kx*(vvel2d(i, k)) vvel2d(i, k + 1) = (dw1 + dw2)/(1.+kx) if (vvel2d(i, k + 1) < 0.) then vvel2d(i, k + 1) = 0.5*vvel2d(i, k) end if end do loop0 end do if (p_smooth) then do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) + 1 vs = 0. dz1m = 0. do k1 = max(k - p_n_smooth, kts), min(k + p_n_smooth, ktf) dz = z_cup(i, k1 + 1) - z_cup(i, k1) vs = vs + dz*vvel2d(i, k1) dz1m = dz1m + dz end do vvel2d(i, k) = vs/(1.e-16 + dz1m) !if(k>ktop(i)-3)print*,"v2=",k,ktop(i),sqrt(vvel2d(i,k)),sqrt(vvel2d(i,ktop(i))) end do end do end if !-- convert to vertical velocity do i = its, itf if (ierr(i) /= 0) cycle vvel2d(i, :) = sqrt(max(0.1, vvel2d(i, :))) if (maxval(vvel2d(i, :)) < 1.0) then ierr(i) = 54 ! print*,"ierr=54",maxval(vvel2d(i,:)) end if !-- sanity check where (vvel2d(i, :) < 1.) vvel2d(i, :) = 1. where (vvel2d(i, :) > 20.) vvel2d(i, :) = 20. vvel2d(i, ktop(i) + 1:kte) = 0.1 !-- get the column average vert velocity do k = kbcon(i), ktop(i) dz = z_cup(i, k + 1) - z_cup(i, k) vvel1d(i) = vvel1d(i) + vvel2d(i, k)*dz !print*,"w=",k,z_cup(i,k),vvel2d(i,k) end do vvel1d(i) = vvel1d(i)/(z_cup(i, ktop(i) + 1) - z_cup(i, kbcon(i)) + 1.e-16) vvel1d(i) = max(1., vvel1d(i)) end do else do i = its, itf if (ierr(i) /= 0) cycle ke = wlpool(i)**2 loop1: do k = start_level(i), kbcon(i) dz = z_cup(i, k + 1) - z_cup(i, k) tve = 0.5*(t_cup(i, k)*(1.+(qo(i, k)/p_eps)/(1.+qo(i, k))) + t_cup(i, k + 1)*(1.+(qo(i, k + 1)/p_eps) & / (1.+qo(i, k + 1)))) tv = 0.5*(tempco(i, k)*(1.+(qco(i, k)/p_eps)/(1.+qco(i, k))) + tempco(i, k + 1)*(1.+(qco(i, k + 1)/p_eps) & / (1.+qco(i, k + 1)))) bu = c_grav*((tv - tve)/tve - ftun2*0.50*(qrco(i, k + 1) + qrco(i, k))) dw1 = 2./(p_f*(1.+p_gam))*bu*dz kx = (1.+p_beta*p_c_d)*max(entr_rate_2d(i, k), cd(i, k))*dz*ftun1 dw2 = ke - 2.*kx*ke ke = max(0., (dw1 + dw2)/(1.+kx)) ! vvel2d(i,k)=sqrt(ke) end do loop1 wlpool_bcon(i) = sqrt(ke) !print*,"wlpool=",wlpool(i),sqrt (ke) end do end if end subroutine cupUpVVel !------------------------------------------------------------------------------------ subroutine cupUpMoisture(name, start_level, klcl, ierr, ierrc, z_cup, qc, qrc, pw, pwav, hc, tempc, xland & ,po, p_cup, kbcon, ktop, cd, dby, clw_all, t_cup, q_env, gamma_cup, zu, qes_cup, k22, qe_cup & ,zqexec, use_excess, ccn, rho, up_massentr, up_massdetr, psum, psumh, c1d, x_add_buoy & ,vvel2d, vvel1d, zws, entr_rate_2d, itest, itf, ktf, ipr, jpr, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpMoisture' ! Nome da subrotina real, parameter :: p_bdispm = 0.366 !! berry--size dispersion (maritime) real, parameter :: p_dispc = 0.146 !! berry--size dispersion (continental) real, parameter :: p_t_bf = 268.16, p_t_ice_bf = 235.16 real, parameter :: p_rk = 3 !! or 2 real, parameter :: p_xexp = 2. ! !Variables (input, output, inout) integer, intent(in) :: use_excess, itest, itf, ktf, its, ite, ipr, jpr, kts, kte integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: start_level(its:ite) real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: p_cup(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: q_env(its:ite, kts:kte) !! environmental q on model levels real, intent(in) :: zu(its:ite, kts:kte) !! normalized updraft mass flux real, intent(in) :: gamma_cup(its:ite, kts:kte) !! gamma on model cloud levels real, intent(in) :: qe_cup(its:ite, kts:kte) !! environmental q on model cloud levels real, intent(in) :: hc(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: up_massentr(its:ite, kts:kte) real, intent(in) :: up_massdetr(its:ite, kts:kte) real, intent(in) :: dby(its:ite, kts:kte) !! buoancy term real, intent(in) :: qes_cup(its:ite, kts:kte) !! saturation q on model cloud levels real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: cd(its:ite, kts:kte) !! detrainment function real, intent(in) :: c1d(its:ite, kts:kte) real, intent(in) :: entr_rate_2d(its:ite, kts:kte) real, intent(in) :: vvel2d(its:ite, kts:kte) real, intent(in) :: zqexec(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: x_add_buoy(its:ite) real, intent(in) :: vvel1d(its:ite) real, intent(in) :: zws(its:ite) real, intent(in) :: ccn(its:ite) character(len=*), intent(in) :: name integer, intent(inout) :: ierr(its:ite) !! ierr error value, maybe modified in this routine character(len=128), intent(inout) :: ierrc(its:ite) real, intent(out) :: qc(its:ite, kts:kte) !! cloud q (including liquid water) after entrainment real, intent(out) :: qrc(its:ite, kts:kte) !! liquid water content in cloud after rainout real, intent(out) :: pw(its:ite, kts:kte) !! condensate that will fall out at that level real, intent(out) :: clw_all(its:ite, kts:kte) real, intent(out) :: tempc(its:ite, kts:kte) real, intent(out) :: pwav(its:ite) !! totan normalized integrated condensate (I1) real, intent(out) :: psum(its:ite) real, intent(out) :: psumh(its:ite) !Local variables: integer :: iounit, iprop, i, k, k1, k2, n, nsteps real :: dp, rhoc, dh, dz, radius, berryc0, q1, berryc real :: qaver, denom, aux, cx0, qrci, step, cbf, qrc_crit_BF, min_liq, qavail real :: delt, tem1, qrc_0, cup real :: qrch !! saturation q in cloud !--- no precip for small clouds !if(name.eq.'shallow') c0 = C0_SHAL !if(name.eq.'mid' ) c0 = C0_MID !if(name.eq.'deep' ) c0 = C0_DEEP do i = its, itf pwav(i) = 0. psum(i) = 0. psumh(i) = 0. end do do k = kts, ktf do i = its, itf pw(i, k) = 0. clw_all(i, k) = 0. tempc(i, k) = t_cup(i, k) qrc(i, k) = 0. !--- liq/ice water qc(i, k) = qe_cup(i, k) !--- total water: liq/ice = vapor water !qc2 (i,k)=qe_cup(i,k) !--- total water: liq/ice = vapor water end do end do !--- get boundary condition for qc do i = its, itf if (ierr(i) /= 0) cycle call getCloudBc(name, kts, kte, ktf, xland(i), po(i, kts:kte), qe_cup(i, kts:kte), qaver, k22(i)) qc(i, kts:start_level(i)) = qaver + zqexec(i) + 1.*x_add_buoy(i)/real(c_xlv) !qc (i,kts:start_level(i)) = qaver + zqexec(i) + 0.67* x_add_buoy(i)/xlv qrc(i, kts:start_level(i)) = 0. !qc (i,kts:start_level(i)) = qaver + zqexec(i) + 0.5*x_add_buoy(i)/xlv !qc2 (i,kts:start_level(i)) = qaver + zqexec(i) + 0.5*x_add_buoy(i)/xlv end do !--- option to produce linear fluxes in the sub-cloud layer. if (trim(name) == 'shallow' .and. USE_LINEAR_SUBCL_MF == 1) then do i = its, itf if (ierr(i) /= 0) cycle call getDelmix(name, kts, kte, ktf, xland(i), start_level(i), po(i, kts:kte), qe_cup(i, kts:kte), qc(i, kts:kte)) end do end if do i = its, itf if (ierr(i) /= 0) cycle do k = start_level(i) + 1, ktop(i) + 1 DZ = Z_cup(i, K) - Z_cup(i, K - 1) ! !--- saturation in cloud, this is what is allowed to be in it ! qrch = qes_cup(I, K) + (1./real(c_xlv))*(gamma_cup(i, k)/(1.+gamma_cup(i, k)))*dby(I, K) !- 1. steady state plume equation, for what could !- be in cloud without condensation denom = (zu(i, k - 1) - .5*up_massdetr(i, k - 1) + up_massentr(i, k - 1)) if (denom > 0.) then qc(i, k) = (qc(i, k - 1)*zu(i, k - 1) - .5*up_massdetr(i, k - 1)*qc(i, k - 1) + up_massentr(i, k - 1) & * q_env(i, k - 1))/denom if (k == start_level(i) + 1) qc(i, k) = qc(i, k) + (zqexec(i) + 0.5*x_add_buoy(i)/real(c_xlv)) & * up_massentr(i, k - 1)/denom !--- assuming no liq/ice water in the environment qrc(i, k) = (qrc(i, k - 1)*zu(i, k - 1) - .5*up_massdetr(i, k - 1)*qrc(i, k - 1))/denom else qc(i, k) = qc(i, k - 1) qrc(i, k) = qrc(i, k - 1) end if ! qc2(i,k)= ( (1.-0.5*entr_rate_2d(i,k-1)*dz)*qc2(i,k-1) & ! + entr_rate_2d(i,k-1)*dz *q (i,k-1) ) / & ! (1.+0.5*entr_rate_2d(i,k-1)*dz) !-- updraft temp tempc(i, k) = (1./real(c_cp))*(hc(i, k) - c_grav*z_cup(i, k) - real(c_xlv)*qrch) !--- total condensed water before rainout clw_all(i, k) = max(0., qc(i, k) - qrch) qrc(i, k) = min(clw_all(i, k), qrc(i, k)) !--- production term => condensation/diffusional growth cup = max(0., qc(i, k) - qrch - qrc(i, k))/dz if (c0 < 1.e-6) then qrc(i, k) = clw_all(i, k) qc(i, k) = qrc(i, k) + min(qc(i, k), qrch) pwav(i) = 0. psum(i) = psum(i) + clw_all(i, k)*zu(i, k)*dz cycle end if if (AUTOCONV == 1) then min_liq = QRC_CRIT*(xland(i)*1.+(1.-xland(i))*0.7) if (name .eq. 'mid') min_liq = min_liq*0.5 cx0 = (c1d(i, k) + c0)*DZ qrc(i, k) = clw_all(i, k)/(1.+cx0) pw(i, k) = cx0*max(0., qrc(i, k) - min_liq)! units kg[rain]/kg[air] !pw (i,k)= cx0*qrc(i,k) ! units kg[rain]/kg[air] !--- convert pw to normalized pw pw(i, k) = pw(i, k)*zu(i, k) elseif (AUTOCONV == 5) then ! C0_DEEP = 1.5e-3; C0_MID = 1.5e-3 ; QRC_CRIT = 1.e-4 !(kg/kg) min_liq = QRC_CRIT*(xland(i)*0.4 + (1.-xland(i))*1.) if (clw_all(i, k) <= min_liq) then !=> more heating at upper levels, more detrained ice qrc(i, k) = clw_all(i, k) pw(i, k) = 0. else cx0 = (c1d(i, k) + c0)*(1.+0.33*FractLiqF(tempc(i, k))) !cx0 = (c1d(i,k)+c0)*(1.+ 2.*FractLiqF(tempc(i,k))) !--- v0 qrc(i, k) = qrc(i, k)*exp(-cx0*dz) + (cup/cx0)*(1.-exp(-cx0*dz)) qrc(i, k) = max(qrc(i, k), min_liq) pw(i, k) = max(0., clw_all(i, k) - qrc(i, k)) ! units kg[rain]/kg[air] qrc(i, k) = clw_all(i, k) - pw(i, k) !--- v1 ! qrc_0 = qrc(i,k) ! qrc(i,k)= (qrc_0-min_liq)*exp(-cx0*dz) + (cup/cx0)*(1.-exp(-cx0*dz))+min_liq ! qrc(i,k)= max(qrc(i,k),min_liq) ! pw (i,k)= max(0.,clw_all(i,k)-qrc(i,k)) ! units kg[rain]/kg[air] ! qrc(i,k)= clw_all(i,k)-pw(i,k) ! qrc(i,k)= (clw_all(i,k)-min_liq)*exp(-cx0*dz)+min_liq ! pw (i,k)= clw_all(i,k)-qrc(i,k) ! units kg[rain]/kg[air] !--- v3 ! qrc(i,k)= (clw_all(i,k)-min_liq) / (1.+cx0*dz)+min_liq ! pw (i,k)= cx0*dz*(qrc(i,k)-min_liq) ! units kg[rain]/kg[air] ! print*,"BG=",k,real(cx0*1.e+3,4),real(pw(i,k),4),real(qrc(i,k),4)& ! ,real(clw_all(i,k)-pw(i,k)-qrc(i,k),4) !==> must be zero !--- convert pw to normalized pw pw(i, k) = pw(i, k)*zu(i, k) end if elseif (AUTOCONV == 6) then min_liq = 0.5*QRC_CRIT*(xland(i)*1.5 + (1.-xland(i))*2.5) if (clw_all(i, k) <= min_liq) then qrc(i, k) = clw_all(i, k) pw(i, k) = 0. else cx0 = (c1d(i, k) + c0)*dz qrc(i, k) = (clw_all(i, k))*exp(-cx0) pw(i, k) = clw_all(i, k) - qrc(i, k) pw(i, k) = pw(i, k)*zu(i, k) end if ! !print*,"6mass=",pw(i,k)/(1.e-12+zu(i,k))+qrc(i,k),clw_all(i,k) elseif (AUTOCONV == 7) then min_liq = 0.5*QRC_CRIT*(xland(i)*1.5 + (1.-xland(i))*2.5) if (clw_all(i, k) <= min_liq) then qrc(i, k) = clw_all(i, k) pw(i, k) = 0. else cx0 = c1d(i, k) + c0 qrc_0 = qrc(i, k) qrc(i, k) = qrc_0*exp(-cx0*dz) + (cup/cx0)*(1.-exp(-cx0*dz)) pw(i, k) = max(clw_all(i, k) - qrc(i, k), 0.) qrc(i, k) = clw_all(i, k) - pw(i, k) pw(i, k) = pw(i, k)*zu(i, k) end if ! !print*,"6mass=",pw(i,k)/(1.e-12+zu(i,k))+qrc(i,k),clw_all(i,k) elseif (AUTOCONV == 3) then min_liq = QRC_CRIT ! * (xland(i)*1.5+(1.-xland(i))*2.5) if (clw_all(i, k) <= min_liq) then qrc(i, k) = clw_all(i, k) pw(i, k) = 0. else DELT = -5. if (t_cup(i, k) > 273.16 + DELT) then aux = 1. else aux = 1.*exp(0.07*(t_cup(i, k) - (273.16 + DELT))) end if cx0 = aux*c0 ! cx0 = max(cx0,c0) ! cx0 = max(cx0,0.25*c0) cx0 = max(cx0, 0.50*c0) qrc_0 = qrc(i, k) qrc(i, k) = qrc_0*exp(-cx0*dz) + (cup/cx0)*(1.-exp(-cx0*dz)) qrc(i, k) = min(clw_all(i, k), qrc(i, k)) pw(i, k) = clw_all(i, k) - qrc(i, k) pw(i, k) = pw(i, k)*zu(i, k) !if(pw(i,k)<0.) stop " pw<0 autoc 3" end if elseif (AUTOCONV == 4) then min_liq = (xland(i)*0.3 + (1.-xland(i))*0.5)*1.e-3 if (clw_all(i, k) > min_liq) then tem1 = FractLiqF(tempc(i, k)) cbf = 1. if (tempc(i, k) < p_t_bf) cbf = 1.+0.5*sqrt(min(max(p_t_bf - tempc(i, k), 0.), p_t_bf - p_t_ice_bf)) !qrc_crit_BF = 0.5e-3/cbf qrc_crit_BF = 3.e-4/cbf cx0 = c0*cbf*(tem1*1.3 + (1.-tem1))/(0.75*min(15., max(vvel2d(i, k), 1.))) !---solution 1 by Runge-Kutta !step = cx0*dz !do n=int(rk),1,-1 ! aux = qrc(i,k)/qrc_crit_BF ! pw (i,k)= auto_rk(n,step,aux,xexp,qrc(i,k)) ! qrc(i,k)= max(clw_all(i,k) - pw(i,k), min_liq) !enddo !--- !---solution 2 by Runge-Kutta !qrc_0 = qrc(i,k) !step = cx0*dz !do n = int(rk),1,-1 !aux = qrc(i,k)/qrc_crit_BF !pw (i,k) =-step*qrc(i,k)*(1.0-exp(-aux**xexp))/float(n) + cup*dz/float(n) !pw (i,k) = max(-qrc_0, pw(i,k)) !qrc(i,k) = qrc_0 + pw(i,k) !enddo !--- !---analytical solution qrc_0 = qrc(i, k) cx0 = cx0*(1.-exp(-(qrc_0/qrc_crit_BF)**2)) qrc(i, k) = qrc_0*exp(-cx0*dz) + (cup/cx0)*(1.-exp(-cx0*dz)) pw(i, k) = max(clw_all(i, k) - qrc(i, k), 0.) !--- convert PW to normalized PW pw(i, k) = pw(i, k)*zu(i, k) !if(pw(i,k)<-1.e-12) stop " pw<0 autoc 4" else pw(i, k) = 0.0 qrc(i, k) = clw_all(i, k) end if end if !- total water (vapor + condensed) in updraft after the rainout qc(i, k) = qrc(i, k) + min(qc(i, k), qrch) !--- integrated normalized condensates pwav(i) = pwav(i) + pw(i, k) psum(i) = psum(i) + clw_all(i, k)*zu(i, k)*dz end do if (pwav(i) < 0.) then ierr(i) = 66 ierrc(i) = "pwav negative" end if end do !--- get back water vapor qc do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) + 1 qc(i, k) = qc(i, k) - qrc(i, k) !if(qc(i,k) < 0.)stop " qc negative" end do end do end subroutine cupUpMoisture !------------------------------------------------------------------------------------ subroutine getMeltingProfile(ierr, tn_cup, po_cup, p_liq_ice, melting_layer, qrco, pwo, edto, pwdo, melting, itf, ktf, its & , ite, kts, kte, cumulus) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getMeltingProfile' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) real, intent(in) :: edto(its:ite) real, intent(in) :: tn_cup(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qrco(its:ite, kts:kte) real, intent(in) :: pwo(its:ite, kts:kte) real, intent(in) :: pwdo(its:ite, kts:kte) real, intent(in) :: p_liq_ice(its:ite, kts:kte) real, intent(in) :: melting_layer(its:ite, kts:kte) character(len=*), intent(in) :: cumulus real, intent(inout) :: melting(its:ite, kts:kte) !Local variables: integer :: i, k real :: dp real, dimension(its:ite) :: norm, total_pwo_solid_phase real, dimension(its:ite, kts:kte) :: pwo_solid_phase, pwo_eff if (p_melt_glac .and. trim(cumulus) == 'deep') then norm = 0.0 pwo_solid_phase = 0.0 pwo_eff = 0.0 melting = 0.0 !-- set melting mixing ratio to zero for columns that do not have deep convection do i = its, itf if (ierr(i) > 0) melting(i, :) = 0. end do !-- now, get it for columns where deep convection is activated total_pwo_solid_phase(:) = 0. do k = kts, ktf - 1 do i = its, itf if (ierr(i) /= 0) cycle dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !-- effective precip (after evaporation by downdraft) !-- pwdo is not defined yet !pwo_eff(i,k) = 0.5*(pwo(i,k)+pwo(i,k+1) + edto(i)*(pwdo(i,k)+pwdo(i,k+1))) pwo_eff(i, k) = 0.5*(pwo(i, k) + pwo(i, k + 1)) !-- precipitation at solid phase(ice/snow) pwo_solid_phase(i, k) = (1.-p_liq_ice(i, k))*pwo_eff(i, k) !-- integrated precip at solid phase(ice/snow) total_pwo_solid_phase(i) = total_pwo_solid_phase(i) + pwo_solid_phase(i, k)*dp/c_grav end do end do do k = kts, ktf do i = its, itf if (ierr(i) /= 0) cycle !-- melting profile (kg/kg) melting(i, k) = melting_layer(i, k)*(total_pwo_solid_phase(i)/(100*(po_cup(i, kts) - po_cup(i, ktf))/c_grav)) !print*,"mel=",k,melting(i,k),pwo_solid_phase(i,k),po_cup(i,k) end do end do !-- check conservation of total solid phase precip ! norm(:)=0. ! DO k=kts,ktf-1 ! DO i=its,itf ! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) ! norm(i) = norm(i) + melting(i,k)*dp/g ! ENDDO ! ENDDO ! ! DO i=its,itf ! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) ! ENDDO !-- else !-- no melting allowed in this run melting(:, :) = 0. end if end subroutine getMeltingProfile !---------------------------------------------------------------------- subroutine getDelmix(cumulus, kts, kte, ktf, xland, subcl_level, po, ain, aout) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getDelmix' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: kts, kte, ktf, subcl_level real, intent(in) :: ain(kts:kte) real, intent(in) :: po(kts:kte) real, intent(in) :: xland character(len=*), intent(in) :: cumulus real, intent(inout) :: aout(kts:kte) !Local variables: integer :: k real :: x1, x2, dp, del, qc qc = aout(kts) x2 = 0. x1 = 0. do k = kts, subcl_level dp = po(k + 1) - po(k) x2 = x2 + dp x1 = x1 + dp*ain(k) end do del = abs(qc - x1/(x2 + 1.e-12)) aout(kts:subcl_level) = ain(kts:subcl_level) + del end subroutine getDelmix !--------------------------------------------------------------------------------------------------- subroutine getJmin(cumulus, itf, ktf, its, ite, kts, kte, ierr, kdet, ktop, kbcon, jmin, ierrc, beta, depth_min, heso_cup & , zo_cup, melting_layer) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getJmin' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kbcon(its:ite) real, intent(in) :: heso_cup(its:ite, kts:kte) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: melting_layer(its:ite, kts:kte) real, intent(in) :: depth_min character(len=*), intent(in) :: cumulus integer, intent(inout) :: ierr(its:ite) integer, intent(inout) :: jmin(its:ite) integer, intent(inout) :: kdet(its:ite) real, intent(out) :: beta character(len=128), intent(out) :: ierrc(its:ite) !Local variables: integer :: i, k, jmini, ki real :: dh, dz real, dimension(its:ite, kts:kte) :: hcdo logical :: keep_going if (trim(cumulus) == 'deep') beta = 0.05 if (trim(cumulus) == 'mid') beta = 0.02 if (trim(cumulus) == 'shallow') then beta = 0.02 jmin(:) = 0 return end if do i = its, itf if (ierr(i) /= 0) cycle if (trim(cumulus) == 'deep' .and. p_melt_glac) jmin(i) = max(jmin(i), maxloc(melting_layer(i, :), 1)) !--- check whether it would have buoyancy, if there where !--- no entrainment/detrainment jmini = jmin(i) keep_going = .true. do while (keep_going) keep_going = .false. if (jmini - 1 .lt. kdet(i)) kdet(i) = jmini - 1 if (jmini .ge. ktop(i) - 1) jmini = ktop(i) - 2 ki = jmini hcdo(i, ki) = heso_cup(i, ki) dz = zo_cup(i, ki + 1) - zo_cup(i, ki) dh = 0. do k = ki - 1, 1, -1 hcdo(i, k) = heso_cup(i, jmini) dz = zo_cup(i, k + 1) - zo_cup(i, k) dh = dh + dz*(hcdo(i, k) - heso_cup(i, k)) if (dh .gt. 0.) then jmini = jmini - 1 if (jmini .gt. 5) then keep_going = .true. else ierr(i) = 9 ierrc(i) = "could not find jmini9" exit end if end if end do end do jmin(i) = jmini if (jmini .le. 5) then ierr(i) = 4 ierrc(i) = "could not find jmini4" end if end do ! - must have at least depth_min m between cloud convective base and cloud top. do i = its, itf if (ierr(i) /= 0) cycle if (jmin(i) - 1 .lt. kdet(i)) kdet(i) = jmin(i) - 1 if (-zo_cup(i, kbcon(i)) + zo_cup(i, ktop(i)) .lt. depth_min) then ierr(i) = 6 ierrc(i) = "cloud depth very shallow" end if end do end subroutine getJmin !------------------------------------------------------------------------------------ subroutine getLateralMassFluxDown(cumulus, itf, ktf, its, ite, kts, kte, ierr, jmin, zo_cup, zdo, xzd, zd, cdd, mentrd_rate_2d & , dd_massentro, dd_massdetro, dd_massentr, dd_massdetr, draft, mentrd_rate, dd_massentru & , dd_massdetru, lambau) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getLateralMassFluxDown' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: jmin(its:ite) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: zdo(its:ite, kts:kte) real, intent(in) :: mentrd_rate(its:ite) real, intent(in) :: lambau(its:ite) character(len=*), intent(in) :: draft character(len=*), intent(in) :: cumulus real, intent(inout) :: cdd(its:ite, kts:kte) real, intent(inout) :: mentrd_rate_2d(its:ite, kts:kte) real, intent(inout) :: xzd(its:ite, kts:kte) real, intent(inout) :: zd(its:ite, kts:kte) real, intent(out) :: dd_massentro(its:ite, kts:kte) real, intent(out) :: dd_massdetro(its:ite, kts:kte) real, intent(out) :: dd_massentr(its:ite, kts:kte) real, intent(out) :: dd_massdetr(its:ite, kts:kte) real, intent(out), optional :: dd_massentru(its:ite, kts:kte) real, intent(out), optional :: dd_massdetru(its:ite, kts:kte) !Local variables: integer ::i, ki real :: dzo cdd = 0. dd_massentr = 0. dd_massdetr = 0. dd_massentro = 0. dd_massdetro = 0. if (present(dd_massentru) .and. present(dd_massdetru)) then dd_massentru = 0. dd_massdetru = 0. end if if (trim(cumulus) == 'shallow') return do i = its, itf if (ierr(i) /= 0) cycle mentrd_rate_2d(i, 1:jmin(i)) = mentrd_rate(i) cdd(i, 1:jmin(i) - 1) = mentrd_rate(i) mentrd_rate_2d(i, 1) = 0. do ki = jmin(i), maxloc(zdo(i, :), 1), -1 !=> from jmin to maximum value zd -> change entrainment dzo = zo_cup(i, ki + 1) - zo_cup(i, ki) dd_massdetro(i, ki) = cdd(i, ki)*dzo*zdo(i, ki + 1) !XXX dd_massentro(i, ki) = zdo(i, ki) - zdo(i, ki + 1) + dd_massdetro(i, ki) dd_massentro(i, ki) = max(0., dd_massentro(i, ki)) !-- check dd_massdetro in case of dd_massentro has been changed above dd_massdetro(i, ki) = dd_massentro(i, ki) - zdo(i, ki) + zdo(i, ki + 1) !~ if(dd_massentro(i,ki).lt.0.)then !~ dd_massentro(i,ki)=0. !~ dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki) !~ if(zdo(i,ki+1) > 0.0)& !~ cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) !~ endif !~ if(zdo(i,ki+1) > 0.0)& !~ mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) end do do ki = maxloc(zdo(i, :), 1) - 1, kts, -1 !=> from maximum value zd to surface -> change detrainment dzo = zo_cup(i, ki + 1) - zo_cup(i, ki) dd_massentro(i, ki) = mentrd_rate_2d(i, ki)*dzo*zdo(i, ki + 1) !XXX dd_massdetro(i, ki) = zdo(i, ki + 1) + dd_massentro(i, ki) - zdo(i, ki) dd_massdetro(i, ki) = max(0.0, dd_massdetro(i, ki)) !-- check dd_massentro in case of dd_massdetro has been changed above dd_massentro(i, ki) = dd_massdetro(i, ki) + zdo(i, ki) - zdo(i, ki + 1) !~ if(dd_massdetro(i,ki).lt.0.)then !~ dd_massdetro(i,ki)=0. !~ dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1) !~ if(zdo(i,ki+1) > 0.0)& !~ mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) !~ endif !~ if(zdo(i,ki+1) > 0.0)& !~ cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) end do do ki = jmin(i), kts, -1 xzd(i, ki) = zdo(i, ki) zd(i, ki) = zdo(i, ki) dd_massentr(i, ki) = dd_massentro(i, ki) dd_massdetr(i, ki) = dd_massdetro(i, ki) end do if (present(dd_massentru) .and. present(dd_massdetru)) then do ki = jmin(i), kts, -1 dd_massentru(i, ki) = dd_massentro(i, ki) + lambau(i)*dd_massdetro(i, ki) dd_massdetru(i, ki) = dd_massdetro(i, ki) + lambau(i)*dd_massdetro(i, ki) end do end if end do end subroutine getLateralMassFluxDown !------------------------------------------------------------------------------------ subroutine getWetbulb(jmin, qo_cup, t_cup, po_cup, q_wetbulb, t_wetbulb) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getWetbulb' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: jmin real, intent(in) :: qo_cup real, intent(in) :: t_cup real, intent(in) :: po_cup real, intent(inout) :: q_wetbulb real, intent(inout) :: t_wetbulb !Local variables: real :: zqp, zcond, zcond1, zcor, zqsat real :: psp, pt, pq real :: z3es, z4es, z5alcp, zaldcp real :: ptare, evap real :: foedelta, f0eewmcu, f0ealfcu, foedemcu, foeldcpmcu !-- for testing ! PSP TEMP Q ZCOND1 ! input 85090.0000000000 289.140030372766 1.105078557441815E-002 ! output 85090.0000000000 287.230570412846 1.181792062536557E-002 -2.761256206705639E-005 ! PT = 289.140030372766 ! PQ = 1.105078557441815E-002 ! PSP = 85090. !---------------------- !-- environmental values pt = t_cup ! K pq = qo_cup ! kg/kg psp = po_cup*100. ! hPa if (pt > c_t00) then z3es = c_r3les z4es = c_r4les z5alcp = c_r5alvcp zaldcp = c_ralvdcp else z3es = c_r3ies z4es = c_r4ies z5alcp = c_r5alscp zaldcp = c_ralsdcp end if !--- get wet bulb thermo properties -------------------------- ptare = pt zqp = 1.0/psp f0ealfcu = min(1.0, ((max(c_rtIce, min(c_t00, ptare)) - c_rtIce)*c_rtwat_rtIce_r)**2) f0eewmcu = c_r2es*(f0ealfcu*exp(c_r3les*(ptare - c_t00)/(ptare - c_r4les)) + & (1.0 - f0ealfcu)*exp(c_r3ies*(ptare - c_t00)/(ptare - c_r4ies))) zqsat = f0eewmcu*zqp zqsat = min(c_max_qsat, zqsat) zcor = 1.0/(1.0 - c_retv*zqsat) zqsat = zqsat*zcor foedemcu = f0ealfcu*c_r5alvcp*(1.0/(ptare - c_r4les)**2) + & (1.0 - f0ealfcu)*c_r5alscp*(1.0/(ptare - c_r4ies)**2) zcond = (pq - zqsat)/(1.0 + zqsat*zcor*foedemcu) zcond = min(zcond, 0.0) foeldcpmcu = f0ealfcu*c_ralvdcp + (1.0 - f0ealfcu)*c_ralsdcp pt = pt + foeldcpmcu*zcond pq = pq - zcond !--update PTARE ptare = pt f0ealfcu = min(1.0, ((max(c_rtIce, min(c_t00, ptare)) - c_rtIce)*c_rtwat_rtIce_r)**2) f0eewmcu = c_r2es*(f0ealfcu*exp(c_r3les*(ptare - c_t00)/(ptare - c_r4les)) + (1.0 - f0ealfcu)*exp(c_r3ies*(ptare - c_t00) & / (ptare - c_r4ies))) zqsat = f0eewmcu*zqp zqsat = min(0.5, zqsat) zcor = 1.0/(1.0 - c_retv*zqsat) zqsat = zqsat*zcor foedemcu = f0ealfcu*c_r5alvcp*(1.0/(ptare - c_r4les)**2) + (1.0 - f0ealfcu)*c_r5alscp*(1.0/(ptare - c_r4ies)**2) zcond1 = (pq - zqsat)/(1.0 + zqsat*zcor*foedemcu) if (zcond == 0.0) zcond1 = min(zcond1, 0.0) foeldcpmcu = f0ealfcu*c_ralvdcp + (1.0 - f0ealfcu)*c_ralsdcp pt = pt + foeldcpmcu*zcond1 pq = pq - zcond1 !-- set output -------------------------- q_wetbulb = pq t_wetbulb = pt evap = -zcond1 != q_wetbulb-qo_cup, source for water vapor end subroutine getWetbulb !------------------------------------------------------------------------------------ subroutine cupDdMoisture(cumulus, ierrc, zd, hcd, hes_cup, qcd, qes_cup, pwd, q_cup, z_cup, dd_massentr & , dd_massdetr, jmin, ierr, gamma_cup, pwev, bu, qrcd, q_env, he, t_cup, iloop, t_wetbulb & , q_wetbulb, qco, pwavo, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupDdMoisture' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: iloop integer, intent(in) :: jmin(its:ite) ! mentr_rate = entrainment rate ! qrch = saturation q in cloud ! pwev = total normalized integrated evaoprate (I2) ! entr = entrainment rate ! cdd = detrainment function ! real, intent(in) :: t_wetbulb(its:ite) real, intent(in) :: q_wetbulb(its:ite) real, intent(in) :: pwavo(its:ite) real, intent(in) :: zd(its:ite, kts:kte) !! normalized downdraft mass flux real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: hes_cup(its:ite, kts:kte) !! saturation h on model cloud levels real, intent(in) :: hcd(its:ite, kts:kte) !! h in model cloud real, intent(in) :: qes_cup(its:ite, kts:kte) !! saturation q on model cloud levels real, intent(in) :: q_cup(its:ite, kts:kte) !! environmental q on model cloud levels real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: dd_massentr(its:ite, kts:kte) real, intent(in) :: dd_massdetr(its:ite, kts:kte) real, intent(in) :: gamma_cup(its:ite, kts:kte) !! gamma on model cloud levels real, intent(in) :: q_env(its:ite, kts:kte) !! environmental q on model levels real, intent(in) :: he(its:ite, kts:kte) real, intent(in) :: qco(its:ite, kts:kte) character(len=*), intent(in) :: cumulus integer, intent(inout) :: ierr(its:ite) real, intent(out) :: qcd(its:ite, kts:kte) !! cloud q (including liquid water) after entrainment !! in-downdradt water vapor mixing ratio real, intent(out) :: qrcd(its:ite, kts:kte) !! saturation water vapor mixing ratio real, intent(out) :: pwd(its:ite, kts:kte) !! evaporate at that level real, intent(out) :: pwev(its:ite) !! column integrated rain evaporation (normalized) real, intent(out) :: bu(its:ite) !! buoancy term !Local variables: character*128 :: ierrc(its:ite) integer :: i, k real :: dh, dz, dq_eva, denom, fix_evap ! bu = 0. qcd = 0. qrcd = 0. pwev = 0. pwd = 0. if (trim(cumulus) == 'shallow') return ! do i = its, itf if (ierr(i) /= 0) cycle !-- boundary condition in jmin ('level of free sinking') k = jmin(i) dz = z_cup(i, k + 1) - z_cup(i, k) qcd(i, k) = q_cup(i, k) if (USE_WETBULB == 1) then !--option 1 !qcd(i,k)=q_wetbulb(i) !--option 2 qcd(i, k) = 0.5*(q_wetbulb(i) + qco(i, k)) ! mixture 50% env air + updraft end if dh = hcd(i, k) - hes_cup(i, k) if (dh .lt. 0) then qrcd(i, k) = (qes_cup(i, k) + (1./real(c_xlv))*(gamma_cup(i, k)/(1.+gamma_cup(i, k)))*dh) else qrcd(i, k) = qes_cup(i, k) end if pwd(i, k) = zd(i, k)*min(0., qcd(i, k) - qrcd(i, k)) qcd(i, k) = qrcd(i, k) pwev(i) = pwev(i) + pwd(i, k) bu(i) = dz*dh do k = jmin(i) - 1, kts, -1 dz = z_cup(i, k + 1) - z_cup(i, k) !-- downward transport + mixing denom = (zd(i, k + 1) - 0.5*dd_massdetr(i, k) + dd_massentr(i, k)) if (denom == 0.0) then qcd(i, k) = qcd(i, k + 1) else qcd(i, k) = (qcd(i, k + 1)*zd(i, k + 1) - 0.5*dd_massdetr(i, k)*qcd(i, k + 1) + dd_massentr(i, k)*q_env(i, k))/denom end if !--- to be negatively buoyant, hcd should be smaller than hes! !--- ideally, dh should be negative till dd hits ground, but that is not always !--- the case dh = hcd(i, k) - hes_cup(i, k) bu(i) = bu(i) + dz*dh qrcd(i, k) = qes_cup(i, k) + (1./real(c_xlv))*(gamma_cup(i, k)/(1.+gamma_cup(i, k)))*dh !-- rain water evaporation amount at layer k dq_eva = qcd(i, k) - qrcd(i, k) if (dq_eva .gt. 0.) then dq_eva = 0. qrcd(i, k) = qcd(i, k) end if !-- amount of the evaporated rain water pwd(i, k) = zd(i, k)*dq_eva ! kg[water vapor]/kg[air] !-- source term for in-downdraft water vapor mixing ratio qcd(i, k) = qrcd(i, k) ! => equiv to qcd = qcd - dq_eva !( -dq_eva >0 => source term for qcd) !-- total evaporated rain water pwev(i) = pwev(i) + pwd(i, k) !-- for GEOS diagnostic ! evap(i,k) = - edt * xmb * zd * dq_eva = - edt * xmb * pwd (i,k) ! downdfrat temp = (hcd(i,k)-qcd(i,k)*xlv-g*z_cup(i,k))/cp - 273.15 end do if (pwev(i) .ge. 0 .and. iloop .eq. 1) then ierr(i) = 70 ierrc(i) = "problem with buoy in cup_dd_moisture" end if if (bu(i) .ge. 0 .and. iloop .eq. 1) then ierr(i) = 73 ierrc(i) = "problem2 with buoy in cup_dd_moisture" end if !-- fix evap, in case of not conservation if (abs(pwev(i)) > pwavo(i) .and. ierr(i) == 0) then fix_evap = pwavo(i)/(1.e-16 + abs(pwev(i))) pwev(i) = 0. do k = jmin(i), kts, -1 pwd(i, k) = pwd(i, k)*fix_evap pwev(i) = pwev(i) + pwd(i, k) dq_eva = pwd(i, k)/(1.e-16 + zd(i, k)) qcd(i, k) = qrcd(i, k) + dq_eva end do if (pwev(i) .ge. 0.) then ierr(i) = 70 ierrc(i) = "problem with buoy in cup_dd_moisture" end if end if end do!--- end loop over i end subroutine cupDdMoisture !------------------------------------------------------------------------------------ subroutine cupUpAa0(aa0, z_cup, zu, dby, gamma_cup, t_cup,k22, klcl, kbcon, ktop, ierr , itf, ktf, its, ite, kts, kte & , integ_interval) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpAa0' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: ierr (its:ite) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: zu(its:ite, kts:kte) !! normalized updraft mass flux real, intent(in) :: gamma_cup(its:ite, kts:kte) !! gamma on model cloud levels real, intent(in) :: t_cup(its:ite, kts:kte) !! temperature (Kelvin) on model cloud levels real, intent(in) :: dby(its:ite, kts:kte) !! buoancy term character(len=*), optional, intent(in) :: integ_interval real, intent(out) :: aa0(its:ite) !! cloud work function !Local variables: integer :: i, k real :: dz, da, aa_2, aa_1 integer, dimension(its:ite) :: kbeg, kend ! initialize array to zero. aa0(:) = 0. ! set domain of integration if (present(integ_interval)) then if (trim(integ_interval) == 'BL') then kbeg(:) = kts kend(:) = kbcon(:) - 1 elseif(trim(integ_interval) == 'CIN') then kbeg(:) = KTS ! k22(:) !klcl (:) ! kts kend(:) = kbcon(:) ! kbcon(:)-1 else stop "unknown range in cup_up_aa0" end if else kbeg(:) = kbcon(:) kend(:) = ktop(:) end if do i = its, itf if (ierr(i) /= 0) cycle do k = kbeg(i), kend(i) dz = z_cup(i, k + 1) - z_cup(i, k) aa_1 = zu(i, k)*(c_grav/(real(c_cp)*t_cup(i, k)))*dby(i, k)/(1.+gamma_cup(i, k)) aa_2 = zu(i, k + 1)*(c_grav/(real(c_cp)*t_cup(i, k + 1)))*dby(i, k + 1)/(1.+gamma_cup(i, k + 1)) da = 0.5*(aa_1 + aa_2)*dz aa0(i) = aa0(i) + da !aa0(i)=aa0(i)+max(0.,da) end do end do end subroutine cupUpAa0 !------------------------------------------------------------------------------------ subroutine cupUpAa1Bl(version, aa1_bl, aa1_fa, aa1, t, tn, q, qo, dtime, po_cup, z_cup, zu, dby, gamma_cup, t_cup, rho, klcl & , kpbl, kbcon, ktop, ierr, itf, ktf, its, ite, kts, kte, xland, ztexec, xlons, xlats, h_sfc_flux & , le_sfc_flux , tau_bl, tau_ecmwf, t_star, cumulus, tn_bl, qo_bl) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpAa1Bl' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, version integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kpbl(its:ite) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: zu(its:ite, kts:kte) !! normalized updraft mass flux real, intent(in) :: gamma_cup(its:ite, kts:kte) !! gamma on model cloud levels real, intent(in) :: t_cup(its:ite, kts:kte) !! temperature (Kelvin) on model cloud levels real, intent(in) :: dby(its:ite, kts:kte) !! buoancy term real, intent(in) :: t(its:ite, kts:kte) real, intent(in) :: tn(its:ite, kts:kte) real, intent(in) :: q(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: tn_bl(its:ite, kts:kte) real, intent(in) :: qo_bl(its:ite, kts:kte) real, intent(in) :: xland(its:ite) real, intent(in) :: ztexec(its:ite) real, intent(in) :: xlons(its:ite) real, intent(in) :: xlats(its:ite) real, intent(in) :: h_sfc_flux(its:ite) real, intent(in) :: le_sfc_flux(its:ite) real, intent(in) :: aa1(its:ite) real, intent(in) :: tau_bl(its:ite) real, intent(in) :: tau_ecmwf(its:ite) real, intent(in) :: dtime real, intent(in) :: t_star character(len=*), intent(in) :: cumulus integer, intent(inout) :: ierr(its:ite) !! ierr error value, maybe modified in this routine real, intent(out) :: aa1_bl(its:ite) real, intent(out) :: aa1_fa(its:ite) !Local variables: integer :: i, k, iprloc real :: dz, da, aa_1, aa_2, tcup, da_bl, a1_bl aa1_bl(:) = 0. if (version == 0) then do i = its, itf if (ierr(i) /= 0) cycle !*** do k=kts,kbcon(i) do k = kts, kpbl(i) dz = c_grav*(z_cup(i, k + 1) - z_cup(i, k)) da = dz*(tn(i, k)*(1.+0.608*qo(i, k)) - t(i, k)*(1.+0.608*q(i, k)))/dtime aa1_bl(i) = aa1_bl(i) + da ! Units : J K / (kg seg) end do end do elseif (version == 1) then do i = its, itf if (ierr(i) /= 0) cycle do k = kts, kpbl(i) dz = (z_cup(i, k + 1) - z_cup(i, k)) aa_1 = (c_grav/(real(c_cp)*t_cup(i, k)))*dby(i, k)*zu(i, k) aa_2 = (c_grav/(real(c_cp)*t_cup(i, k + 1)))*dby(i, k + 1)*zu(i, k + 1) da = 0.5*(aa_1 + aa_2)*dz! Units : J / kg aa1_bl(i) = aa1_bl(i) + da end do end do else stop "unknown version option in routine: cup_up_aa1bl" end if return aa1_fa(:) = 0. do i = its, itf if (ierr(i) /= 0) cycle do k = kbcon(i), ktop(i) dz = z_cup(i, k + 1) - z_cup(i, k) aa_1 = (c_grav/(real(c_cp)*((t_cup(i, k)))))*dby(i, k)/(1.+gamma_cup(i, k))*zu(i, k) aa_2 = (c_grav/(real(c_cp)*((t_cup(i, k + 1)))))*dby(i, k + 1)/(1.+gamma_cup(i, k + 1))*zu(i, k + 1) da = 0.5*(aa_1 + aa_2)*dz aa1_fa(i) = aa1_fa(i) + da end do end do end subroutine cupUpAa1Bl !---------------------------------------------------------------------------------------------- subroutine getQadv(cumulus, itf, ktf, its, ite, kts, kte, ierr, dt, q, qo, qo_adv, po, po_cup, qeso, q_adv, col_sat_adv & , alpha_adv, tau_bl, zo_cup, kbcon, ktop) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getQadv' ! Nome da subrotina real, parameter :: p_ptop = 60. !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: q(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: qo_adv(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qeso(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: tau_bl(its:ite) real, intent(in) :: dt character(len=*), intent(in) :: cumulus real, intent(inout) :: q_adv(its:ite) real, intent(inout) :: col_sat_adv(its:ite) real, intent(inout) :: alpha_adv(its:ite) !Local variables: integer :: i, k real :: dp, layer, H_cloud, dz !-- get the advective moisture tendency scaled with the relative humidity !-- Q_adv = integral( q/q* DQv/Dt_adv dp), see Eq 1 Becker et al(2021 QJRMS) !-- units here are "J m^-3" _or_ "J kg^-1" do i = its, itf col_sat_adv(i) = 0. !check if it needs be inout, perhavps only local var if (ierr(i) /= 0) cycle alpha_adv(i) = ALPHA_ADV_TUNING layer = 0. loopN: do k = kts, ktf if (po(i, k) < p_ptop) exit loopN !dp=100.*(po_cup(i,k+1)-po_cup(i,k)) ! dp < 0. dz = zo_cup(i, k + 1) - zo_cup(i, k) ! dz > 0 !-- integral over dp !Q_adv(i) = Q_adv(i) + dp*(qo(i,k)/qeso(i,k))*(qo_adv(i,k)-q(i,k))/dt !-- integral over dz q_adv(i) = q_adv(i) + dz*(qo(i, k)/qeso(i, k))*(qo_adv(i, k) - q(i, k))/dt col_sat_adv(i) = col_sat_adv(i) + dz*qo(i, k)/qeso(i, k) layer = layer + dz end do loopN !-- get the column-average saturation fraction col_sat_adv(i) = col_sat_adv(i)/(1.e-8 + layer) !--check if the col-ave saturation fraction is over the threshold if (col_sat_adv(i) > col_sat_adv_threshold) then alpha_adv(i) = 0.0 cycle end if !-- check if cloud top _OR_cloud layer !<<<< check this H_cloud = zo_cup(i, ktop(i)) - zo_cup(i, kbcon(i)) !-- convert Q_adv to units as in Eq (1) => J m^-3 !Q_adv(i) = - Q_adv(i) * tau_bl(i) * xlv / (g * H_cloud) !-- convert Q_adv to units as in cloud work function => J kg-1 q_adv(i) = q_adv(i)*tau_bl(i)*real(c_xlv)/(H_cloud) !if(abs(q_adv(i))>1.) print*,"Qadv=",i,q_adv(i),Q_adv_dz(i)call flush(6) end do end subroutine getQadv !------------------------------------------------------------------------------------ subroutine cupDdEdt(cumulus, ierr, us, vs, z, ktop, kbcon, edt, p, pwav, pw, ccn, pwev, edtmax, edtmin, maxens2, edtc, psum2 & , psumh, rho, aeroevap, itf, ktf, ipr, jpr, its, ite, kts, kte, vshear) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupDdEdt' ! Nome da subrotina real, parameter :: p_alpha3 = 1.9, p_beta3 = -1.13 !Variables (input, output, inout) integer, intent(in) :: ipr, jpr, aeroevap, itf, ktf, its, ite, kts, kte, maxens2 integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kbcon(its:ite) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: us(its:ite, kts:kte) real, intent(in) :: vs(its:ite, kts:kte) real, intent(in) :: z(its:ite, kts:kte) real, intent(in) :: p(its:ite, kts:kte) real, intent(in) :: pw(its:ite, kts:kte) real, intent(in) :: pwav(its:ite) real, intent(in) :: pwev(its:ite) real, intent(in) :: ccn(its:ite) real, intent(in) :: psum2(its:ite) real, intent(in) :: psumh(its:ite) real, intent(in) :: edtmax(its:ite) real, intent(in) :: edtmin(its:ite) character(len=*), intent(in) :: cumulus integer, intent(inout) :: ierr(its:ite) real, intent(out) :: edtc(its:ite, 1:maxens2) real, intent(out) :: edt(its:ite) real, intent(out) :: vshear(its:ite) !Local variables: integer :: i, k, kk real :: einc, pef, pefb, prezk, zkbc real, dimension(its:ite) :: vws, sdp real :: pefc, aeroadd, rhoc, dp, prop_c ! determine downdraft strength in terms of windshear ! calculate an average wind shear over the depth of the cloud edt = 0. vws = 0. sdp = 0. vshear = 0. edtc = 0. if (trim(cumulus) == 'shallow') return do i = its, itf if (ierr(i) /= 0) cycle do kk = kbcon(i), ktop(i) dp = p(i, kk) - p(i, kk + 1) vws(i) = vws(i) + (abs((us(i, kk + 1) - us(i, kk))/(z(i, kk + 1) - z(i, kk))) + abs((vs(i, kk + 1) - vs(i, kk)) & / (z(i, kk + 1) - z(i, kk))))*dp sdp(i) = sdp(i) + dp end do vshear(i) = 1.e3*vws(i)/sdp(i) end do do i = its, itf if (ierr(i) /= 0) cycle pef = (1.591 - 0.639*vshear(i) + 0.0953*(vshear(i)**2) - 0.00496*(vshear(i)**3)) !print*,"shear=",vshear(i),pef,1-max(min(pef,0.9),0.1) pef = min(pef, 0.9) pef = max(pef, 0.1) edt(i) = 1.-pef !--- cloud base precip efficiency if (USE_REBCB == 0) then zkbc = z(i, kbcon(i))*3.281e-3 prezk = 0.02 if (zkbc > 3.0) prezk = 0.96729352 + zkbc*(-0.70034167 + zkbc * (0.162179896 + zkbc*(-1.2569798e-2 + zkbc & * (4.2772e-4 - zkbc*5.44e-6)))) if (zkbc > 25.) prezk = 2.4 pefb = 1./(1.+prezk) pefb = min(pefb, 0.9) pefb = max(pefb, 0.1) edt(i) = 1.-0.5*(pefb + pef) end if if (aeroevap .gt. 1) then aeroadd = (c_ccnclean**p_beta3)*((psumh(i))**(p_alpha3 - 1)) !*1.e6 !if(i.eq.ipr)write(0,*)'edt',ccnclean,psumh(i),aeroadd !prop_c=.9/aeroadd prop_c = .5*(pefb + pef)/aeroadd aeroadd = (ccn(i)**p_beta3)*((psum2(i))**(p_alpha3 - 1)) !*1.e6 !if(i.eq.ipr)write(0,*)'edt',ccn(i),psum2(i),aeroadd,prop_c aeroadd = prop_c*aeroadd pefc = aeroadd if (pefc .gt. 0.9) pefc = 0.9 if (pefc .lt. 0.1) pefc = 0.1 EDT(I) = 1.-pefc if (aeroevap .eq. 2) EDT(I) = 1.-.25*(pefb + pef + 2.*pefc) end if end do do i = its, itf if (ierr(i) /= 0) cycle edtc(i, 1) = -edt(i)*pwav(i)/pwev(i) edtc(i, 1) = min(edtmax(i), edtc(i, 1)) edtc(i, 1) = max(edtmin(i), edtc(i, 1)) end do end subroutine cupDdEdt !--------------------------------------------------------------------------------------------------- subroutine tridiag(m_size, aa, bb, cc, ff) !! solves the problem: aa*ff(k-1,t+1) + bb*ff(k,t+1) + cc*ff(k+1,t+1) = dd !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! This routine solves the problem: aa*ff(k-1,t+1) + bb*ff(k,t+1) + cc*ff(k+1,t+1) = dd !! an updated "ff" at time t+1 is the output !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'tridiag' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: m_size real, intent(in) :: aa(m_size) real, intent(in) :: bb(m_size) real, intent(inout) :: cc(m_size) real, dimension(m_size), intent(inout) :: ff !Local variables: real, dimension(m_size) :: qq integer :: k real :: pp cc(m_size) = 0. qq(1) = -cc(1)/bb(1) ff(1) = ff(1)/bb(1) do k = 2, m_size pp = 1./(bb(k) + aa(k)*qq(k - 1)) qq(k) = -cc(k)*pp ff(k) = pp*(ff(k) - aa(k)*ff(k - 1)) end do do k = m_size - 1, 1, -1 ff(k) = ff(k) + qq(k)*ff(k + 1) end do end subroutine tridiag !----------------------------------------------------------------------------------------- subroutine fct1d3(ktop, n, dt, z, tracr, massflx, trflx_in, del_out) !! modify a 1-D array of tracer fluxes for the purpose of maintaining monotonicity !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! modify a 1-D array of tracer fluxes for the purpose of maintaining !! monotonicity (including positive-definiteness) in the tracer field !! during tracer transport. !! the underlying transport equation is (d tracr/dt) = - (d trflx/dz) !! where dz = |z(k+1)-z(k)| (k=1,...,n) and trflx = massflx * tracr !! note: tracr is carried in grid cells while z and fluxes are carried on !! interfaces. interface variables at index k are at grid location k-1/2. !! sign convention: mass fluxes are considered positive in +k direction. !! massflx and trflx_in must be provided independently to allow the !! algorithm to generate an auxiliary low-order (diffusive) tracer flux !! as a stepping stone toward the final product trflx_out. !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'fct1d3' ! Nome da subrotina logical, parameter :: p_hi_order = .false. real, parameter :: p_epsil = 1.e-22 !! prevent division by zero real, parameter :: p_damp = 1. !! damper of antidff flux (1=no damping) !Variables (input, output, inout) integer, intent(in) :: n !! number of grid cells integer, intent(in) :: ktop real, intent(in) :: dt !! transport time step real, intent(in) :: z(n + 0) !! location of cell interfaces real, intent(in) :: tracr(n) !! the transported variable real, intent(in) :: massflx(n + 0) !! mass flux across interfaces real, intent(in) :: trflx_in(n + 0) !! original tracer flux real, intent(out):: del_out(n + 0) !! modified tracr flux !Local variables: real :: trflx_out(n + 0) !! modified tracr flux integer :: k, km1, kp1 logical :: nan, error = .false., vrbos = .false. real :: dtovdz(n), trmax(n), trmin(n), flx_lo(n + 0), antifx(n + 0), clipped(n + 0), soln_hi(n), totlin(n), totlout(n) real :: soln_lo(n), clipin(n), clipout(n), arg nan(arg) = .not. (arg .ge. 0. .or. arg .le. 0.) ! NaN detector soln_lo(:) = 0. antifx(:) = 0. clipout(:) = 0. flx_lo(:) = 0. do k = 1, ktop dtovdz(k) = .01*dt/abs(z(k + 1) - z(k)) ! time step / grid spacing ! if (z(k).eq.z(k+1)) error=.true. end do if (vrbos .or. error) print '(a/(8es10.3))', '(fct1d) dtovdz =', dtovdz(1:ktop) do k = 2, ktop if (massflx(k) > 0.) then flx_lo(k) = massflx(k)*tracr(k - 1) ! low-order flux, upstream else flx_lo(k) = massflx(k)*tracr(k) ! low-order flux, upstream end if antifx(k) = trflx_in(k) - flx_lo(k) ! antidiffusive flux end do flx_lo(1) = trflx_in(1) flx_lo(ktop + 1) = trflx_in(ktop + 1) antifx(1) = 0. antifx(ktop + 1) = 0. ! --- clip low-ord fluxes to make sure they don't violate positive-definiteness do k = 1, ktop totlout(k) = max(0., flx_lo(k + 1)) - min(0., flx_lo(k)) ! total flux out clipout(k) = min(1., tracr(k)/max(p_epsil, totlout(k))/(1.0001*dtovdz(k))) end do do k = 2, ktop if (massflx(k) .ge. 0.) then flx_lo(k) = flx_lo(k)*clipout(k - 1) else flx_lo(k) = flx_lo(k)*clipout(k) end if end do if (massflx(1) .lt. 0.) flx_lo(1) = flx_lo(1)*clipout(1) if (massflx(ktop + 1) .gt. 0.) flx_lo(ktop + 1) = flx_lo(ktop + 1)*clipout(ktop) ! --- a positive-definite low-order (diffusive) solution can now be constructed do k = 1, ktop soln_lo(k) = tracr(k) - (flx_lo(k + 1) - flx_lo(k))*dtovdz(k) ! low-ord solutn del_out(k) = -c_grav*(flx_lo(k + 1) - flx_lo(k))*dtovdz(k)/dt end do if (.not. p_hi_order) return soln_hi(:) = 0. clipin(:) = 0. trmin(:) = 0. trmax(:) = 0. clipped(:) = 0. trflx_out(:) = 0. do k = 1, ktop km1 = max(1, k - 1) kp1 = min(n, k + 1) trmax(k) = max(soln_lo(km1), soln_lo(k), soln_lo(kp1), tracr(km1), tracr(k), tracr(kp1)) ! upper bound trmin(k) = max(0., min(soln_lo(km1), soln_lo(k), soln_lo(kp1), tracr(km1), tracr(k), tracr(kp1))) ! lower bound end do do k = 1, ktop totlin(k) = max(0., antifx(k)) - min(0., antifx(k + 1)) ! total flux in totlout(k) = max(0., antifx(k + 1)) - min(0., antifx(k)) ! total flux out clipin(k) = min(p_damp, (trmax(k) - soln_lo(k))/max(p_epsil, totlin(k))/(1.0001*dtovdz(k))) clipout(k) = min(p_damp, (soln_lo(k) - trmin(k))/max(p_epsil, totlout(k))/(1.0001*dtovdz(k))) if (nan(clipin(k))) print *, '(fct1d) error: clipin is NaN, k=', k if (nan(clipout(k))) print *, '(fct1d) error: clipout is NaN, k=', k if (clipin(k) .lt. 0.) then print 100, '(fct1d) error: clipin < 0 at k =', k, & 'clipin', clipin(k), 'trmax', trmax(k), 'soln_lo', soln_lo(k), & 'totlin', totlin(k), 'dt/dz', dtovdz(k) error = .true. end if if (clipout(k) .lt. 0.) then print 100, '(fct1d) error: clipout < 0 at k =', k, & 'clipout', clipout(k), 'trmin', trmin(k), 'soln_lo', soln_lo(k), & 'totlout', totlout(k), 'dt/dz', dtovdz(k) error = .true. end if 100 format(a, i3/(4(a10, "=", es9.2))) end do do k = 2, ktop if (antifx(k) .gt. 0.) then clipped(k) = antifx(k)*min(clipout(k - 1), clipin(k)) else clipped(k) = antifx(k)*min(clipout(k), clipin(k - 1)) end if trflx_out(k) = flx_lo(k) + clipped(k) if (nan(trflx_out(k))) then print *, '(fct1d) error: trflx_out is NaN, k=', k error = .true. end if end do trflx_out(1) = trflx_in(1) trflx_out(ktop + 1) = trflx_in(ktop + 1) do k = 1, ktop soln_hi(k) = tracr(k) - (trflx_out(k + 1) - trflx_out(k))*dtovdz(k) del_out(k) = -c_grav*(trflx_out(k + 1) - trflx_out(k))*dtovdz(k)/dt !write(32,*)'3',k,soln_lo(k),soln_hi(k) end do if (vrbos .or. error) then do k = 2, ktop write (32, 99) k, & 'tracr(k)', tracr(k), & 'flx_in(k)', trflx_in(k), & 'flx_in(k+1)', trflx_in(k + 1), & 'flx_lo(k)', flx_lo(k), & 'flx_lo(k+1)', flx_lo(k + 1), & 'soln_lo(k)', soln_lo(k), & 'trmin(k)', trmin(k), & 'trmax(k)', trmax(k), & 'totlin(k)', totlin(k), & 'totlout(k)', totlout(k), & 'clipin(k-1)', clipin(k - 1), & 'clipin(k)', clipin(k), & 'clipout(k-1)', clipout(k - 1), & 'clipout(k)', clipout(k), & 'antifx(k)', antifx(k), & 'antifx(k+1)', antifx(k + 1), & 'clipped(k)', clipped(k), & 'clipped(k+1)', clipped(k + 1), & 'flx_out(k)', trflx_out(k), & 'flx_out(k+1)', trflx_out(k + 1), & 'dt/dz(k)', dtovdz(k), & 'final', tracr(k) - (trflx_out(k + 1) - trflx_out(k))*dtovdz(k) 99 format('(trc1d) k =', i4/(3(a13, '=', es13.6))) end do if (error) stop '(fct1d error)' end if end subroutine fct1d3 !------------------------------------------------------------------------------------ subroutine cupForcingEns3d(itf, ktf, its, ite, kts, kte, ens4, ensdim, ichoice, maxens, maxens2, maxens3 & , ierr, ierr2, ierr3, k22, kbcon, ktop, xland, aa0, aa1, xaa0, mbdt, dtime & , xf_ens, mconv, qo, p_cup, omeg, zd, zu, pr_ens, edt, tau_ecmwf, aa1_bl & , xf_dicycle, xk_x, alpha_adv, Q_adv, aa1_radpbl, aa1_adv, wlpool, xf_coldpool) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupForcingEns3d' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, ens4, ensdim, maxens, maxens2, maxens3 integer, intent(in) :: k22(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: ichoice !! flag if only want one closure (usually set to zero!) ! massfln = downdraft mass flux ensembles used in next timestep ! dir = "storm motion" ! iact_gr_old = flag to tell where convection was active ! kbcon = LFC of parcel from k22 ! k22 = updraft originating level ! name = deep or shallow convection flag real, intent(in) :: aa1_bl(its:ite) real, intent(in) :: tau_ecmwf(its:ite) real, intent(in) :: alpha_adv(its:ite) real, intent(in) :: Q_adv(its:ite) real, intent(in) :: aa1_radpbl(its:ite) real, intent(in) :: aa1_adv(its:ite) real, intent(in) :: wlpool(its:ite) real, intent(in) :: zd(its:ite, kts:kte) !! downdraft normalized mass flux real, intent(in) :: zu(its:ite, kts:kte) !! updraft normalized mass flux real, intent(in) :: p_cup(its:ite, kts:kte) real, intent(in) :: qo(its:ite, kts:kte) real, intent(in) :: omeg(its:ite, kts:kte, 1:ens4) !! omega from large scale model real, intent(in) :: xaa0(its:ite) !! cloud work function with cloud effects real, intent(in) :: aa1(its:ite) !! cloud work function with forcing effects real, intent(in) :: edt(its:ite) !! epsilon real, intent(in) :: xland(its:ite) real, intent(in) :: aa0(its:ite) !! cloud work function without forcing effects real, intent(in) :: mbdt(its:ite) !! arbitrary numerical parameter real, intent(in) :: dtime !! dt over which forcing is applied integer, intent(inout) :: ierr(its:ite) !! ierr error value, maybe modified in this routine integer, intent(inout) :: ierr2(its:ite) integer, intent(inout) :: ierr3(its:ite) real, intent(inout) :: pr_ens(its:ite, 1:ensdim) !! precipitation ensemble real, intent(inout) :: mconv(its:ite) !! moisture convergence from large scale model real, intent(inout) :: xf_dicycle(its:ite) real, intent(inout) :: xk_x(its:ite) real, intent(inout) :: xf_coldpool(its:ite) real, intent(out) :: xf_ens(its:ite, 1:ensdim) !! mass flux ensembles !Local variables: integer :: i, k, nall, n, ne, nens, nens3, kk real :: a1, a_ave, xff0, xomg real :: betajb, ke real :: xff_dicycle real, dimension(1:maxens3) :: xff_ens3 real, dimension(its:ite) :: xk real, dimension(its:ite) :: ens_adj!,xmbmax ens_adj(:) = 1. ! large scale forcing do i = its, itf xf_ens(i, 1:16) = 0. if (ierr(i) /= 0) cycle xff0 = (aa1(I) - aa0(I))/dtime !-- default xff_ens3(1) = max(0., (aa1(I) - aa0(I))/dtime) xff_ens3(2) = xff_ens3(1) xff_ens3(3) = xff_ens3(1) xff_ens3(16) = xff_ens3(1) ! !--- more like Brown (1979), or Frank-Cohen (199?) !--- omeg is in Pa/s xomg = 0. kk = 0 xff_ens3(4) = 0. do k = max(kts, kbcon(i) - 1), kbcon(i) + 1 !- betajb=(zu(i,k)-edt(i)*zd(i,k)) betajb = 1. !if(betajb .gt. 0.)then xomg = xomg - omeg(i, k, 1)/c_grav/betajb kk = kk + 1 !endif end do if (kk .gt. 0) xff_ens3(4) = xomg/float(kk) ! kg[air]/m^3 * m/s xff_ens3(4) = max(0.0, xff_ens3(4)) xff_ens3(5) = xff_ens3(4) xff_ens3(6) = xff_ens3(4) xff_ens3(14) = xff_ens3(4) ! !--- more like Krishnamurti et al.; ! !mconv(i) = 0. !do k=k22(i),ktop(i) ! mconv(i)=mconv(i)+omeg(i,k,1)*(qo(i,k+1)-qo(i,k))/g !enddo !- 2nd option (assuming that omeg(ktop)*q(ktop)<< omeg(kbcon)*q(kbcon)) mconv(i) = -omeg(i, kbcon(i), 1)*qo(i, kbcon(i))/c_grav ! (kg[air]/m^3)*m/s*kg[water]/kg[air] mconv(i) = max(0., mconv(i)) xff_ens3(7) = mconv(i) xff_ens3(8) = xff_ens3(7) xff_ens3(9) = xff_ens3(7) xff_ens3(15) = xff_ens3(7) ! !---- more like Betchold et al (2014). Note that AA1 already includes the forcings tendencies xff_ens3(10) = aa1(i)/tau_ecmwf(i) xff_ens3(11) = xff_ens3(10) xff_ens3(12) = xff_ens3(10) xff_ens3(13) = xff_ens3(10) ! if (ichoice == 0) then if (xff0 < 0.) then xff_ens3(1) = 0. xff_ens3(2) = 0. xff_ens3(3) = 0. xff_ens3(16) = 0. xff_ens3(10) = 0. xff_ens3(11) = 0. xff_ens3(12) = 0. xff_ens3(13) = 0. end if end if xk(i) = (xaa0(I) - (aa1(I)))/mbdt(i) if (xk(i) .le. 0. .and. xk(i) .gt. -0.1*mbdt(i)) xk(i) = -0.1*mbdt(i) if (xk(i) .gt. 0. .and. xk(i) .lt. 1.e-2) xk(i) = 1.e-2 ! !--- over water, enfor!e small cap for some of the closures ! !if(xland(i).lt.0.1)then ! if(ierr2(i).gt.0.or.ierr3(i).gt.0)then ! xff_ens3(1:16) = ens_adj(i)*xff_ens3(1:16) ! endif !endif ! !--- special treatment for stability closures ! if (xk(i) .lt. 0.) then if (xff_ens3(1) .gt. 0.) xf_ens(i, 1) = max(0., -xff_ens3(1)/xk(i)) if (xff_ens3(2) .gt. 0.) xf_ens(i, 2) = max(0., -xff_ens3(2)/xk(i)) if (xff_ens3(3) .gt. 0.) xf_ens(i, 3) = max(0., -xff_ens3(3)/xk(i)) if (xff_ens3(16) .gt. 0.) xf_ens(i, 16) = max(0., -xff_ens3(16)/xk(i)) else xff_ens3(1) = 0. xff_ens3(2) = 0. xff_ens3(3) = 0. xff_ens3(16) = 0. end if xf_ens(i, 4) = max(0., xff_ens3(4)) xf_ens(i, 5) = max(0., xff_ens3(5)) xf_ens(i, 6) = max(0., xff_ens3(6)) xf_ens(i, 14) = max(0., xff_ens3(14)) a1 = max(1.e-3, pr_ens(i, 7)) xf_ens(i, 7) = max(0., xff_ens3(7)/a1) a1 = max(1.e-3, pr_ens(i, 8)) xf_ens(i, 8) = max(0., xff_ens3(8)/a1) a1 = max(1.e-3, pr_ens(i, 9)) xf_ens(i, 9) = max(0., xff_ens3(9)/a1) a1 = max(1.e-3, pr_ens(i, 15)) xf_ens(i, 15) = max(0., xff_ens3(15)/a1) if (xk(i) .lt. 0.) then xf_ens(i, 10) = max(0., -xff_ens3(10)/xk(i)) xf_ens(i, 11) = max(0., -xff_ens3(11)/xk(i)) xf_ens(i, 12) = max(0., -xff_ens3(12)/xk(i)) xf_ens(i, 13) = max(0., -xff_ens3(13)/xk(i)) else xf_ens(i, 10) = 0. xf_ens(i, 11) = 0. xf_ens(i, 12) = 0. xf_ens(i, 13) = 0. end if if (ichoice .ge. 1) then xf_ens(i, 1:16) = xf_ens(i, ichoice) end if !---special combination for 'ensemble closure': !---over the land, only applies closures 1 and 10. !if(ichoice == 0 .and. xland(i) < 0.1)then ! xf_ens(i,1:16) =0.5*(xf_ens(i,10)+xf_ens(i,1)) !endif !------------------------------------ end do !- !- diurnal cycle mass flux closure !- if (DICYCLE == 1 .or. DICYCLE == 2) then do i = its, itf xf_dicycle(i) = 0. ! if(ierr(i) /= 0 .or. p_cup(i,kbcon(i))< 950. )cycle if (ierr(i) /= 0) cycle !--- Bechtold et al (2014) !xff_dicycle = (AA1(i)-AA1_BL(i))/tau_ecmwf(i) !--- Bechtold et al (2014) + Becker et al (2021) xff_dicycle = (1.-alpha_adv(i))*aa1(i) + alpha_adv(i)*aa1_radpbl(i) & + alpha_adv(i)*Q_adv(i) - aa1_bl(i) !xff_dicycle = Q_adv(i) xff_dicycle = xff_dicycle/tau_ecmwf(i) if (xk(i) .lt. 0) xf_dicycle(i) = max(0., -xff_dicycle/xk(i)) xf_dicycle(i) = xf_ens(i, 10) - xf_dicycle(i) !---------- ! if(xk(i).lt.0) then ! xf_dicycle(i)= max(0.,-xff_dicycle/xk(i)) ! xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) ! else ! xf_dicycle(i)= 0. ! endif ! xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) !---------- end do elseif (DICYCLE == 3) then do i = its, itf xf_dicycle(i) = 0. if (ierr(i) /= 0) cycle xff_dicycle = (1.-alpha_adv(i))*aa1(i) + alpha_adv(i)*(aa1_radpbl(i) + aa1_adv(i)) - aa1_bl(i) ! + alpha_adv(i) *(AA1_RADPBL(i) + AA1_ADV(i) - AA0(i)) & !--------tmp ! xff_dicycle = AA1_ADV(i) !--------tmp xff_dicycle = xff_dicycle/tau_ecmwf(i) if (xk(i) .lt. 0) xf_dicycle(i) = max(0., -xff_dicycle/xk(i)) xf_dicycle(i) = xf_ens(i, 10) - xf_dicycle(i) end do elseif (DICYCLE == 4) then do i = its, itf xf_dicycle(i) = 0. if (ierr(i) /= 0) cycle !the signal "-" is to convert from Pa/s to kg/m2/s if (xk_x(i) > 0.) xf_dicycle(i) = max(0., -aa1_bl(I))/xk_x(i) xf_ens(i, :) = xf_dicycle(i) xf_dicycle(i) = 0.0 end do else xf_dicycle(:) = 0.0 end if !------------------------------------ !- !- add the kinetic energy at the gust front at the !- mass flux closure !- if (ADD_COLDPOOL_CLOS == 4) then do i = its, itf if (ierr(i) /= 0 .or. xk(i) >= 0) cycle xf_coldpool(i) = -(0.5*wlpool(i)**2/tau_ecmwf(i))/xk(i) end do end if end subroutine cupForcingEns3d !------------------------------------------------------------------------------------ subroutine cupForcingEns3dMid(aa0, aa1, xaa0, mbdt, dtime, ierr, po_cup, ktop, k22, kbcon, kpbl, ichoice & , maxens, maxens3, itf, ktf, its, ite, kts, kte, tau_ecmwf, aa1_bl, xf_dicycle & , dhdt, xff_mid, zws, hc, hco, he_cup, heo_cup, wlpool, xf_coldpool) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupForcingEns3dMid' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, maxens, maxens3 integer, intent(in) :: ichoice !! flag if only want one closure integer, intent(in) :: k22(its:ite) !! updraft originating level integer, intent(in) :: kbcon(its:ite) !! LFC of parcel from k22 integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kpbl(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: dhdt(its:ite, kts:kte) real, intent(in) :: hc(its:ite, kts:kte) real, intent(in) :: hco(its:ite, kts:kte) real, intent(in) :: he_cup(its:ite, kts:kte) real, intent(in) :: heo_cup(its:ite, kts:kte) real, intent(in) :: aa1_bl(its:ite) real, intent(in) :: tau_ecmwf(its:ite) real, intent(in) :: wlpool(its:ite) real, intent(in) :: xaa0(its:ite) !! cloud work function with cloud effects real, intent(in) :: aa1(its:ite) !! cloud work function with forcing effects real, intent(in) :: zws(its:ite) real, intent(in) :: mbdt(its:ite) !! arbitrary numerical parameter real, intent(in) :: aa0(its:ite) !! cloud work function without forcing effects real, intent(in) :: dtime !! dt over which forcing is applied integer, intent(inout) :: ierr(its:ite) real, intent(inout) :: xf_dicycle(its:ite) real, intent(inout) :: xf_coldpool(its:ite) real, intent(out) :: xff_mid(its:ite, 1:maxens3) !Local variables: real, dimension(1:maxens) :: xk integer :: i, k real :: xff_dicycle, trash, blqe, xff_ens1, mf_ens1 do i = its, itf !-initialization xff_mid(i, :) = 0. xf_dicycle(i) = 0. if (ierr(i) /= 0) cycle !- Think about this: !xff0= (AA1(I)-AA0(I))/DTIME !if(xff0.lt.0.) xff_dicycle = 0. xk(1) = (xaa0(i) - (aa1(i)))/mbdt(i) if (xk(1) .le. 0 .and. xk(1) .gt. -0.1*mbdt(i)) xk(1) = -0.1*mbdt(i) if (xk(1) .gt. 0 .and. xk(1) .lt. 1.e-2) xk(1) = 1.e-2 !- closure 3 for mid if (xk(1) < 0.) xff_mid(i, 3) = max(0., -(aa1(i)/tau_ecmwf(i))/xk(1)) end do do i = its, itf if (ierr(i) /= 0) cycle !- Boundary layer quasi-equilibrium (Raymond 1995) if (k22(i) .lt. kpbl(i) + 1) then blqe = 0. do k = kts, kbcon(i) !- orig formulation !do k=kts,kpbl(i) blqe = blqe + 100.*dhdt(i, k)*(po_cup(i, k) - po_cup(i, k + 1))/c_grav end do !trash = max((hc (i,kbcon(i))-he_cup (i,kbcon(i))),1.e1)!- orig formulation trash = max((hco(i, kbcon(i)) - heo_cup(i, kbcon(i))), 1.e1) xff_mid(i, 2) = max(0., blqe/trash) end if !- W* closure (Grant,2001) xff_mid(i, 1) = 0.03*zws(i) end do end subroutine cupForcingEns3dMid !------------------------------------------------------------------------------------ subroutine cupUpCape(aa0, z, zu, dby, gamma_cup, t_cup, k22, kbcon, ktop, ierr, tempco, qco, qrco, qo_cup & , itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpCape' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: k22(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: z(its:ite, kts:kte) !! heights of model levels real, intent(in) :: zu(its:ite, kts:kte) !! normalized updraft mass flux real, intent(in) :: gamma_cup(its:ite, kts:kte) ! gamma on model cloud levels real, intent(in) :: t_cup(its:ite, kts:kte) !! temperature (Kelvin) on model cloud levels real, intent(in) :: dby(its:ite, kts:kte) !! buoancy term real, intent(in) :: tempco(its:ite, kts:kte) !! in-cloud temperature (Kelvin) on model cloud levels real, intent(in) :: qco(its:ite, kts:kte) !! in-cloud water vapor mixing ratio on model cloud levels real, intent(in) :: qrco(its:ite, kts:kte) !! in-cloud liquid water mixing ratio on model cloud levels real, intent(in) :: qo_cup(its:ite, kts:kte) !! environ water vapor mixing ratio on model cloud levels integer, intent(inout) :: ierr(its:ite) !! error value, maybe modified in this routine real, intent(out) :: aa0(its:ite) !! dummy array for CAPE (total cape) !Local variables: integer :: i, k real :: dz, daa0 ! aa0(:) = 0. do i = its, itf if (ierr(i) == 0) then do k = kbcon(i), ktop(i) dz = z(i, k) - z(i, max(1, k - 1)) daa0 = c_grav*dz*((tempco(i, k)*(1.+0.608*qco(i, k)) - t_cup(i, k)*(1.+0.608*qo_cup(i, k))) /(t_cup(i, k) & * (1.+0.608*qo_cup(i, k))) & ) aa0(i) = aa0(i) + max(0., daa0) !~ print*,"cape",k,AA0(I),tempco(i,k),t_cup(i,k), qrco (i,k) end do end if end do end subroutine cupUpCape !------------------------------------------------------------------------------------ subroutine cupForcingEns3dShal(itf, ktf, its, ite, kts, kte, dtime, ichoice, ierrc, ierr, klcl, kpbl, kbcon, k22, ktop & , xmb, tsur, cape, h_sfc_flux, le_sfc_flux, zws, po, hco, heo_cup, po_cup, t_cup, dhdt & , rho, xff_shal2d, xf_dicycle, tke_pbl, wlpool, xf_coldpool) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupForcingEns3dShal' ! Nome da subrotina real, parameter :: p_k1 = 1.2 !! tuning numbers for the TKE-based closure for shallow convection real, parameter :: p_cloud_area = 0.15 !! tuning numbers for the TKE-based closure for shallow convection !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, ichoice integer, intent(in) :: klcl(its:ite) integer, intent(in) :: kpbl(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: dtime real, intent(in) :: tsur(its:ite) real, intent(in) :: cape(its:ite) real, intent(in) :: h_sfc_flux(its:ite) real, intent(in) :: le_sfc_flux(its:ite) real, intent(in) :: zws(its:ite) real, intent(in) :: tke_pbl(its:ite) real, intent(in) :: wlpool(its:ite) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: hco(its:ite, kts:kte) real, intent(in) :: heo_cup(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: dhdt(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) integer, intent(inout):: ierr(its:ite) real, intent(inout) :: xmb(its:ite) real, intent(inout) :: xf_dicycle(its:ite) real, intent(inout) :: xf_coldpool(its:ite) character(len=128), intent(inout):: ierrc(its:ite) real, intent(out) :: xff_shal2d(its:ite, p_shall_closures) !Local variables: real, dimension(its:ite) :: xmbmax integer :: i, k, kbase real :: blqe, trash, tcold, fin, fsum, efic, thot, dp real, dimension(p_shall_closures) :: xff_shal do i = its, itf xmb(i) = 0. xf_dicycle(i) = 0. if (ierr(i) /= 0) cycle xmbmax(i) = 100.*(po(i, kbcon(i)) - po(i, kbcon(i) + 1))/(c_grav*dtime) !- limiting the mass flux at cloud base xmbmax(i) = min(p_xmbmaxshal, xmbmax(i)) !- cloud base kbase = kbcon(i) !kbase=klcl(i) !--- closure from Grant (2001): ichoice = 1 xff_shal(1) = .030*zws(i)*rho(i, kpbl(i)) xff_shal(2) = xff_shal(1) xff_shal(3) = xff_shal(1) !--- closure from the heat-engine principle : ichoice = 4 !- Renno and Ingersoll(1996), Souza et al (1999) !- get the averaged environment temperature between cloud base !- and cloud top tcold = 0. do k = kbase, ktop(i) dp = po_cup(i, k) - po_cup(i, k + 1) tcold = tcold + t_cup(i, k)*dp end do tcold = tcold/(po_cup(i, kbase) - po_cup(i, ktop(i) + 1)) !-surface temperature thot = tsur(i) ! + ztexec(i) !- thermodynamic eficiency !efic = max(0.05, (thot-tcold)/thot ) efic = max(0.0, (thot - tcold)/thot) !- total heat flux from surface fin = max(0.0, h_sfc_flux(i) + le_sfc_flux(i)) !--- mass flux at cloud base !if(cape(i) > 0.0 .and. h_sfc_flux(i) >0.0 ) then if (cape(i) > 0.0) then xff_shal(4) = efic*fin/cape(i) else xff_shal(4) = 0.0 end if xff_shal(5) = xff_shal(4) xff_shal(6) = xff_shal(4) !--- closure from boundary layer QE (Raymond 1995): ichoice = 7 blqe = 0. trash = 0. if (k22(i) .lt. kpbl(i) + 1) then do k = kts, kbase blqe = blqe + 100.*dhdt(i, k)*(po_cup(i, k) - po_cup(i, k + 1))/c_grav end do trash = max((hco(i, kbase) - heo_cup(i, kbase)), 1.e1) xff_shal(7) = max(0., blqe/trash) else xff_shal(7) = 0.0 end if xff_shal(8) = xff_shal(7) xff_shal(9) = xff_shal(7) !--- new closure based on the PBL TKE mean (Zheng et al, 2020 GRL): ichoice = 10 !-- shallow cumulus active area is for now keept by 0.15 (Zheng 2021 p. commun.) !-- k1 is 'slope' of the curve between Wb x (TKE_PBL)**0.5 !-- and varies between 1.2 (from lidar) to 1.6 (from WRF and SAM models) xff_shal(10) = p_cloud_area*rho(i, kbase)*p_k1*sqrt(tke_pbl(i)) xff_shal(11) = xff_shal(10) xff_shal(12) = xff_shal(10) !--- store all closures for later. xff_shal2d(i, :) = xff_shal(:) end do end subroutine cupForcingEns3dShal !------------------------------------------------------------------------------------ subroutine keToHeating(itf, ktf, its, ite, kts, kte, ktop, ierr, po_cup, us, vs, dellu, dellv, dellat) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'keToHeating' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: us(its:ite, kts:kte) real, intent(in) :: vs(its:ite, kts:kte) real, intent(in) :: dellu(its:ite, kts:kte) real, intent(in) :: dellv(its:ite, kts:kte) real, intent(inout) :: dellat(its:ite, kts:kte) !Local variables: real :: dts, fp, dp, fpi integer ::i, k ! since kinetic energy is being dissipated, add heating accordingly (from ECMWF) do i = its, itf if (ierr(i) /= 0) cycle dts = 0. fpi = 0. do k = kts, ktop(i) dp = (po_cup(i, k) - po_cup(i, k + 1))*100. !total KE dissiptaion estimate dts = dts - (dellu(i, k)*us(i, k) + dellv(i, k)*vs(i, k))*dp/c_grav ! ! fpi needed for calcualtion of conversion to pot. energyintegrated fpi = fpi + sqrt(dellu(i, k)*dellu(i, k) + dellv(i, k)*dellv(i, k))*dp end do if (fpi .gt. 0.) then do k = kts, ktop(i) fp = sqrt((dellu(i, k)*dellu(i, k) + dellv(i, k)*dellv(i, k)))/fpi dellat(i, k) = dellat(i, k) + fp*dts*c_grav/real(c_cp) end do end if end do end subroutine keToHeating !------------------------------------------------------------------------------------ subroutine cupOutputEns3d(cumulus, xff_shal, xff_mid, xf_ens, ierr, dellat, dellaq, dellaqc, outtem, outq, outqc & , zu, pre, pw, xmb, ktop, nx, nx2, ierr2, ierr3, pr_ens, maxens3, ensdim, sig, xland1 & , ichoice, ipr, jpr, itf, ktf, its, ite, kts, kte, xf_dicycle, outu, outv, dellu, dellv & , dtime, po_cup, kbcon, dellabuoy, outbuoy, dellampqi, outmpqi, dellampql, outmpql & , dellampcf, outmpcf, nmp, rh_dicycle_fct, xf_coldpool, wlpool_bcon) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupOutputEns3d' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: ichoice, ipr, jpr, itf, ktf, its, ite, kts, kte integer, intent(in) :: ensdim, nx, nx2, maxens3, nmp integer, intent(in) :: ktop(its:ite) integer, intent(in) :: kbcon(its:ite) real, intent(in) :: zu(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: sig(its:ite) real, intent(in) :: rh_dicycle_fct(its:ite) real, intent(in) :: wlpool_bcon(its:ite) real, intent(in) :: xff_mid(its:ite, maxens3) real, intent(in) :: dellampqi(nmp, its:ite, kts:kte) real, intent(in) :: dellampql(nmp, its:ite, kts:kte) real, intent(in) :: dellampcf(nmp, its:ite, kts:kte) real, intent(in) :: xff_shal(its:ite, p_shall_closures) real, intent(in) :: dtime character(len=*), intent(in) :: cumulus integer, intent(inout) :: ierr(its:ite) !! ierr error value, maybe modified in this routine integer, intent(inout) :: ierr2(its:ite) integer, intent(inout) :: ierr3(its:ite) real, intent(inout) :: xland1(its:ite) real, intent(inout) :: dellat(its:ite, kts:kte) !! change of temperature per unit mass flux of cloud ensemble real, intent(inout) :: dellaqc(its:ite, kts:kte) !! change of qc per unit mass flux of cloud ensemble real, intent(inout) :: dellaq(its:ite, kts:kte) !! change of q per unit mass flux of cloud ensemble real, intent(inout) :: pw(its:ite, kts:kte) !! epsilon*pd (ensemble dependent) real, intent(inout) :: dellu(its:ite, kts:kte) real, intent(inout) :: dellv(its:ite, kts:kte) real, intent(inout) :: dellabuoy(its:ite, kts:kte) real, intent(inout) :: xf_ens(its:ite, 1:ensdim) !! ensemble mass fluxes real, intent(inout) :: pr_ens(its:ite, 1:ensdim) !! precipitation ensembles real, intent(inout) :: xf_dicycle(its:ite) real, intent(inout) :: xf_coldpool(its:ite) real, intent(out) :: outtem(its:ite, kts:kte) !! output temp tendency (per s) real, intent(out) :: outq(its:ite, kts:kte) !! output q tendency (per s) real, intent(out) :: outqc(its:ite, kts:kte) !! output qc tendency (per s) real, intent(out) :: outu(its:ite, kts:kte) real, intent(out) :: outv(its:ite, kts:kte) real, intent(out) :: outbuoy(its:ite, kts:kte) real, intent(out) :: outmpqi(nmp, its:ite, kts:kte) real, intent(out) :: outmpql(nmp, its:ite, kts:kte) real, intent(out) :: outmpcf(nmp, its:ite, kts:kte) real, intent(out) :: pre(its:ite) !! output precip real, intent(out) :: xmb(its:ite) !! total base mass flux !Local variables: integer :: i, k, n, ncount, zmax, kk, kqmx, ktmx real :: outtes, ddtes, dtt, dtq, dtqc, dtpw, prerate, fixouts, dp, xfix_q, xfix_t real :: dtts, dtqs, fsum, rcount real, dimension(its:ite) :: xmb_ave, xmbmax real, dimension(kts:kte, 8) :: tend2d real, dimension(8) :: tend1d real, dimension(its:ite, 8) :: check_cons_I, check_cons_F ! do k = kts, ktf do i = its, itf outtem(i, k) = 0. outq(i, k) = 0. outqc(i, k) = 0. outu(i, k) = 0. outv(i, k) = 0. outbuoy(i, k) = 0. end do end do do i = its, itf pre(i) = 0. xmb(i) = 0. xmb_ave(i) = 0. end do do i = its, itf if (ierr(i) .eq. 0) then do n = 1, maxens3 if (pr_ens(i, n) .le. 0.) then xf_ens(i, n) = 0. end if end do end if end do !--- calculate ensemble average mass fluxes if (trim(cumulus) == 'deep') then do i = its, itf if (ierr(i) .eq. 0) then k = 0 xmb_ave(i) = 0. do n = 1, maxens3 k = k + 1 xmb_ave(i) = xmb_ave(i) + xf_ens(i, n) end do !- 'ensemble' average mass flux xmb_ave(i) = xmb_ave(i)/float(k) end if end do !- mid (congestus type) convection elseif (trim(cumulus) == 'mid') then if (ichoice .le. 3) then do i = its, itf if (ierr(i) /= 0) cycle if (ichoice == 0) then xmb_ave(i) = 0.3333*(xff_mid(i, 1) + xff_mid(i, 2) + xff_mid(i, 3)) else xmb_ave(i) = xff_mid(i, ichoice) end if end do else stop 'For mid ichoice must be 0,1,2,3' end if !- shallow convection elseif (trim(cumulus) == 'shallow') then do i = its, itf if (ierr(i) /= 0) cycle if (ichoice > 0) then xmb_ave(i) = xff_shal(i, ichoice) else fsum = 0. xmb_ave(i) = 0. do k = 1, p_shall_closures !- heat engine closure is not working properly !- turning it off for now. if (k .ge. 4 .and. k .le. 6) cycle xmb_ave(i) = xmb_ave(i) + xff_shal(i, k) fsum = fsum + 1. end do !- ensemble average of mass flux xmb_ave(i) = xmb_ave(i)/fsum end if end do end if !- apply the mean tropospheric RH control on diurnal cycle (Tian GRL 2022) if (trim(cumulus) == 'deep' .and. RH_DICYCLE == 1) then do i = its, itf if (ierr(i) /= 0) cycle xf_dicycle(i) = xf_dicycle(i)*rh_dicycle_fct(i) end do end if !if(trim(cumulus) == 'deep' ) then ! do i=its,itf !!! if(ierr(i) /= 0) cycle ! print*,'xmbs',xmb_ave(i),xf_dicycle(i),xf_coldpool(i),wlpool_bcon(i) ! call flush(6) ! enddo !endif !- set the updraft mass flux, do not allow negative values and apply the diurnal cycle closure do i = its, itf if (ierr(i) /= 0) cycle !- mass flux of updradt at cloud base xmb(i) = xmb_ave(i) !- add kinetic energy at the gust front of the cold pools xmb(i) = xmb(i) + xf_coldpool(i) !- diurnal cycle closure xmb(i) = xmb(i) - xf_dicycle(i) if (xmb(i) .le. 0.) then ierr(i) = 13 xmb(i) = 0. end if end do !-apply the scale-dependence Arakawa's approach do i = its, itf if (ierr(i) /= 0) cycle !- scale dependence xmb(i) = sig(i)*xmb(i) !- apply the adjust factor for tunning !xmb(i) = FADJ_MASSFLX * xmb(i) if (xmb(i) == 0.) ierr(i) = 14 if (xmb(i) > 100.) ierr(i) = 15 end do !--- sanity check for mass flux ! do i = its, itf if (ierr(i) /= 0) cycle xmbmax(i) = 100.*(po_cup(i, kbcon(i)) - po_cup(i, kbcon(i) + 1))/(c_grav*dtime) xmb(i) = min(xmb(i), xmbmax(i)) end do !--- check outtem and and outq for high values !--- criteria: if abs (dT/dt or dQ/dt) > 100 K/day => fix xmb if (MAX_TQ_TEND < -1.e-6) then do i = its, itf if (ierr(i) /= 0) cycle fixouts = xmb(i)*86400.*max(maxval(abs(dellat(i, kts:ktop(i)))), (real(c_xlv)/real(c_cp))*maxval(abs & ( dellaq(i, kts:ktop(i))))) if (fixouts > abs(MAX_TQ_TEND)) then ! K/day fixouts = abs(MAX_TQ_TEND)/(fixouts) xmb(i) = xmb(i)*fixouts xf_ens(i, :) = xf_ens(i, :)*fixouts end if end do end if !--- criteria: if abs (dT/dt or dQ/dt) > 100 K/day => fix dT/dt, dQ/dt and xmb if (MAX_TQ_TEND > 1.e-6) then do i = its, itf if (ierr(i) /= 0) cycle tend1d = 0. do k = kts, ktop(i) dp = (po_cup(i, k) - po_cup(i, k + 1)) tend1d(1) = tend1d(1) + dp*xmb(i)*86400.*(dellat(i, k)) if (xmb(i)*86400.*abs(dellat(i, k)) > MAX_TQ_TEND) dellat(i, k) = MAX_TQ_TEND/(xmb(i)*86400)*sign(1., dellat(i, k)) tend1d(2) = tend1d(2) + dp*xmb(i)*86400.*(dellat(i, k)) end do do k = kts, ktop(i) dp = (po_cup(i, k) - po_cup(i, k + 1)) tend1d(3) = tend1d(3) + dp*xmb(i)*86400.*(dellaq(i, k))*(real(c_xlv)/real(c_cp)) if (xmb(i)*86400.*abs(dellaq(i, k))*(real(c_xlv)/real(c_cp)) > MAX_TQ_TEND) dellaq(i, k) = MAX_TQ_TEND & / (xmb(i)*86400*(real(c_xlv)/real(c_cp)))*sign(1., dellaq(i, k)) tend1d(4) = tend1d(4) + dp*xmb(i)*86400.*(dellaq(i, k))*(real(c_xlv)/real(c_cp)) end do xfix_t = tend1d(1)/(1.e-6 + tend1d(2)) xfix_q = tend1d(3)/(1.e-6 + tend1d(4)) xmb(i) = xmb(i)/max(1., max(xfix_q, xfix_t)) ! print*,"tend", end do end if ! !-- now do feedback ! do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) pre(i) = pre(i) + pw(i, k)*xmb(i) outtem(i, k) = dellat(i, k)*xmb(i) outq(i, k) = dellaq(i, k)*xmb(i) outqc(i, k) = dellaqc(i, k)*xmb(i) outu(i, k) = dellu(i, k)*xmb(i) outv(i, k) = dellv(i, k)*xmb(i) outbuoy(i, k) = dellabuoy(i, k)*xmb(i) end do xf_ens(i, :) = sig(i)*xf_ens(i, :) if (APPLY_SUB_MP == 1) then do k = kts, ktop(i) outmpqi(:, i, k) = dellampqi(:, i, k)*xmb(i) outmpql(:, i, k) = dellampql(:, i, k)*xmb(i) outmpcf(:, i, k) = dellampcf(:, i, k)*xmb(i) end do outmpqi(:, i, ktop(i):ktf) = 0. outmpql(:, i, ktop(i):ktf) = 0. outmpcf(:, i, ktop(i):ktf) = 0. end if end do ! end subroutine cupOutputEns3d !--------------------------------------------------------------------------------------------------- subroutine getPrecipFluxes(cumulus, klcl, kbcon, ktop, k22, ierr, xland, pre, xmb, pwo, pwavo, edto, pwevo, pwdo & , t_cup, tempco, prec_flx, evap_flx, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getPrecipFluxes' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: ierr(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: pwavo(its:ite) real, intent(in) :: pwevo(its:ite) real, intent(in) :: edto(its:ite) real, intent(in) :: pre(its:ite) real, intent(in) :: xmb(its:ite) real, intent(in) :: pwo(its:ite, kts:kte) real, intent(in) :: pwdo(its:ite, kts:kte) real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) character(len=*), intent(in) :: cumulus real, intent(out) :: prec_flx(its:ite, kts:kte) !! units kg[water]/m2/s real, intent(out) :: evap_flx (its:ite, kts:kte) !! units kg[water]/m2/s !Local variables: integer :: i, k prec_flx = 0.0 evap_flx = 0.0 if (c0 < 1.e-6) return do i = its, itf if (ierr(i) /= 0) cycle do k = ktop(i), kts, -1 !--- precipitation flux (at 'cup' levels), units: kg[water]/m2/s prec_flx(i, k) = prec_flx(i, k + 1) + xmb(i)*(pwo(i, k) + edto(i)*pwdo(i, k)) prec_flx(i, k) = max(0., prec_flx(i, k)) !--- evaporation flux (at 'cup' levels), units: kg[water]/m2/s evap_flx(i, k) = evap_flx(i, k + 1) - xmb(i)*edto(i)*pwdo(i, k) evap_flx(i, k) = max(0., evap_flx(i, k)) ! !--for future use (rain and snow precipitation fluxes) !p_liq_ice(i,k) = FractLiqF(tempco(i,k)) !prec_flx_rain(k) = prec_flx(i,k)*(1.-p_liq_ice(k)) !prec_flx_snow(k) = prec_flx(i,k)* p_liq_ice(k) end do !if(prec_flx (i,kts) .ne. pre(i)) then !print*,"error=",100.*(prec_flx (i,kts) - pre(i))/(1.e-16+pre(i)),pre(i),prec_flx (i,kts) !STOP 'problem with water balance' !endif end do end subroutine getPrecipFluxes !--------------------------------------------------------------------------------------------------- subroutine rainEvapBelowCloudBase(cumulus, itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, xmb, psur, xland & , qo_cup, t_cup, po_cup, qes_cup, pwavo, edto, pwevo, pwo, pwdo & , pre, prec_flx, evap_flx, outt, outq, outbuoy, evap_bcb) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'rainEvapBelowCloudBase' ! Nome da subrotina real, parameter :: p_alpha1 = 5.44e-4 !! 1/sec real, parameter :: p_alpha2 = 5.09e-3 !! unitless real, parameter :: p_alpha3 = 0.5777 !! unitless real, parameter :: p_c_conv = 0.05 !!conv fraction area, unitless !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: psur(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: pwavo(its:ite) real, intent(in) :: edto(its:ite) real, intent(in) :: pwevo(its:ite) real, intent(in) :: xmb(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qo_cup(its:ite, kts:kte) real, intent(in) :: qes_cup(its:ite, kts:kte) real, intent(in) :: pwo(its:ite, kts:kte) real, intent(in) :: pwdo(its:ite, kts:kte) real, intent(in) :: t_cup(its:ite, kts:kte) character(len=*), intent(in) :: cumulus real, intent(inout) :: pre(its:ite) real, intent(inout) :: outt(its:ite, kts:kte) real, intent(inout) :: outq(its:ite, kts:kte) real, intent(inout) :: outbuoy(its:ite, kts:kte) real, intent(inout) :: prec_flx(its:ite, kts:kte) real, intent(inout) :: evap_flx(its:ite, kts:kte) real, intent(out) :: evap_bcb(its:ite, kts:kte) !Local variables: integer :: i, k real :: rh_cr, del_t, del_q, dp, q_deficit, pqsat, temp_pre real :: rh_cr_ocean, rh_cr_land real, dimension(its:ite) :: tot_evap_bcb, eff_c_conv if (trim(cumulus) == 'shallow') then rh_cr_ocean = 1. rh_cr_land = 1. eff_c_conv(:) = min(0.2, max(xmb(:), p_c_conv)) else rh_cr_ocean = 0.95 !test 0.90 rh_cr_land = 0.90 eff_c_conv(:) = p_c_conv end if prec_flx = 0.0 evap_flx = 0.0 tot_evap_bcb = 0.0 if (c0 < 1.e-6) return do i = its, itf if (ierr(i) /= 0) cycle !-- critical rel humidity - check this, if the value is too small, not evapo will take place. rh_cr = rh_cr_ocean*xland(i) + rh_cr_land*(1.0 - xland(i)) !if(xland(i) < 0.90 ) then !- over land ! RH_cr = RH_cr_LAND !else ! RH_cr = RH_cr_OCEAN !endif do k = ktop(i), kts, -1 dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !p_liq_ice(i,k) = FractLiqF(tempco(i,k)) !---rainfall evaporation below cloud base if (k <= kbcon(i)) then q_deficit = max(0., (rh_cr*qes_cup(i, k) - qo_cup(i, k))) !pqsat=SaturSpecHum(t_cup(i,k),po_cup(i,k)) !--units here: kg[water]/kg[air}/sec evap_bcb(i, k) = eff_c_conv(i)*p_alpha1*q_deficit * (sqrt(po_cup(i, k)/psur(i))/p_alpha2*prec_flx(i, k + 1) & / eff_c_conv(i))**p_alpha3 !--units here: kg[water]/kg[air}/sec * kg[air]/m3 * m = kg[water]/m2/sec evap_bcb(i, k) = evap_bcb(i, k)*dp/c_grav else evap_bcb(i, k) = 0.0 end if !-- before anything check if the evaporation already consumed all precipitation temp_pre = pre(i) - evap_bcb(i, k) if (temp_pre < 0.) evap_bcb(i, k) = pre(i) !-- get the net precitation flux after the local evaporation and downdraft prec_flx(i, k) = prec_flx(i, k + 1) - evap_bcb(i, k) + xmb(i)*(pwo(i, k) + edto(i)*pwdo(i, k)) prec_flx(i, k) = max(0., prec_flx(i, k)) evap_flx(i, k) = evap_flx(i, k + 1) + evap_bcb(i, k) - xmb(i)*edto(i)*pwdo(i, k) evap_flx(i, k) = max(0., evap_flx(i, k)) tot_evap_bcb(i) = tot_evap_bcb(i) + evap_bcb(i, k) !-- feedback del_q = evap_bcb(i, k)*c_grav/dp ! > 0., units: kg[water]/kg[air}/sec del_t = -evap_bcb(i, k)*c_grav/dp*(real(c_xlv)/real(c_cp)) ! < 0., units: K/sec outq(i, k) = outq(i, k) + del_q outt(i, k) = outt(i, k) + del_t !--- comment out 17nov !outbuoy(i,k) = outbuoy(i,k) + cp*del_t+xlv*del_q pre(i) = pre(i) - evap_bcb(i, k) !--for future use (rain and snow precipitation fluxes) !prec_flx_rain(k) = prec_flx(i,k)*(1.-p_liq_ice(k)) !prec_flx_snow(k) = prec_flx(i,k)* p_liq_ice(k) end do if (pre(i) < 0.) then print *, "prec evap neg for cumulus=", pre(i), trim(cumulus) call flush (6) !stop '@subroutine rain_evap_below_cloudbase' end if end do end subroutine rainEvapBelowCloudBase !------------------------------------------------------------------------------------ subroutine cloudDissipation(cumulus, itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, dtime, xmb, xland & , qo_cup, qeso_cup, po_cup, outt, outq, outqc, zuo, vvel2d, rho_hydr & , qrco, sig, tempco, qco, tn_cup, heso_cup, zo) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cloudDissipation' ! Nome da subrotina real, parameter :: p_cloud_lifetime = 1800. integer, parameter :: p_versionx = 2 !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: xmb(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: sig(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qo_cup(its:ite, kts:kte) real, intent(in) :: qeso_cup(its:ite, kts:kte) real, intent(in) :: zuo(its:ite, kts:kte) real, intent(in) :: vvel2d(its:ite, kts:kte) real, intent(in) :: rho_hydr(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) real, intent(in) :: qco(its:ite, kts:kte) real, intent(in) :: tn_cup(its:ite, kts:kte) real, intent(in) :: heso_cup(its:ite, kts:kte) real, intent(in) :: zo(its:ite, kts:kte) real, intent(in) :: dtime character(len=*), intent(in) :: cumulus real, intent(inout) :: outt(its:ite, kts:kte) real, intent(inout) :: outq(its:ite, kts:kte) real, intent(inout) :: outqc(its:ite, kts:kte) real, intent(inout) :: qrco(its:ite, kts:kte) !Local variables: integer :: i, k real :: del_t, del_q, dp, frh real :: qrc_diss, fractional_area, outqc_diss, outq_mix, outt_diss, outt_mix, tempx, qvx do i = its, itf if (ierr(i) /= 0) cycle do k = ktop(i), kbcon(i), -1 !--- cloud liq/ice remained in the convection plume qrc_diss = max(0., qrco(i, k) - outqc(i, k)*dtime) !dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) !--- get relative humidity frh = 0. !min(qo_cup(i,k)/qeso_cup(i,k),1.) !--- estimation of the fractional area fractional_area = (xmb(i)/sig(i))*zuo(i, k)/(rho_hydr(i, k)*vvel2d(i, k)) !--- source of enviroment moistening/cooling due to the 'remained' cloud dissipation into it. outqc_diss = (qrc_diss*(1.-frh))/p_cloud_lifetime if (p_versionx == 1 .or. p_coupl_mphysics .eqv. .false.) then outt_diss = -outqc_diss*(real(c_xlv)/real(c_cp)) !--- cooling !--- source of enviroment moistening/warming due to the 'remained' in-cloud water vapor mixing into it. ! qvx = qco (i,k) ! tempx = tempco(i,k) qvx = qeso_cup(i, k) tempx = (heso_cup(i, k) - c_grav*zo(i, k) - real(c_xlv)*qeso_cup(i, k))/real(c_cp) outq_mix = (qvx - qo_cup(i, k))/p_cloud_lifetime outt_mix = (tempx - tn_cup(i, k))/p_cloud_lifetime !-- feedback del_q = (outqc_diss + outq_mix)*USE_CLOUD_DISSIPATION*fractional_area ! units: kg[water]/kg[air}/sec del_t = (outt_diss + outt_mix)*USE_CLOUD_DISSIPATION*fractional_area ! units: K/sec outq(i, k) = outq(i, k) + del_q outt(i, k) = outt(i, k) + del_t else outqc(i, k) = outqc(i, k) + outqc_diss*fractional_area*USE_CLOUD_DISSIPATION end if !print*,"diss2=",k,real(outqc_diss*86400.*1000),real(sqrt(1.-sig(i)),4),real( fractional_area*100.,4) qrco(i, k) = max(0., qrco(i, k) - outqc_diss*USE_CLOUD_DISSIPATION*fractional_area*dtime) !if(qrco (i,k) <0.) print*,"qrc<0",trim(cumulus),qrco(i,k) end do end do end subroutine cloudDissipation !------------------------------------------------------------------------------------ subroutine cupUpLightning(itf, ktf, its, ite, kts, kte, ierr, kbcon, ktop, xland, cape, zo, zo_cup, t_cup, t, tempco & , qrco, po_cup, rho, prec_flx, lightn_dens) !! Lightning parameterization !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com> !! **Date**: 10-Aug-2019 !! !! **Full description**: !! !! Lightning parameterization based on: !! "A Lightning Parameterization for the ECMWF Integrated Forecasting System" !! P. Lopez, 2016 MWR !! !! Coded/adapted to the GF scheme by Saulo Freitas (10-Aug-2019) !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupUpLightning' ! Nome da subrotina real, parameter :: p_v_graup = 3.0 !! m/s real, parameter :: p_v_snow = 0.5 !! m/s real, parameter :: p_beta_land = 0.70 !! 1 real, parameter :: p_beta_ocean = 0.45 !! 1 real, parameter :: p_alpha = 37.5 !! 1 real, parameter :: p_t_initial = 0.0 + 273.15 !! K real, parameter :: p_t_final = -25.+273.15 !! K !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: cape(its:ite) real, intent(in) :: xland(its:ite) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: zo_cup(its:ite, kts:kte) real, intent(in) :: t_cup(its:ite, kts:kte) real, intent(in) :: t(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) real, intent(in) :: zo(its:ite, kts:kte) real, intent(in) :: qrco(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: prec_flx(its:ite, kts:kte) real, intent(out) :: lightn_dens(its:ite) !! lightning flash density - rate (units: 1/km2/day) !Local variables: integer :: i, k, k_initial, k_final real :: q_r, z_base, beta, prec_flx_fr, dz real, dimension(kts:kte) :: p_liq_ice, q_graup, q_snow do i = its, itf lightn_dens(i) = 0.0 if (ierr(i) /= 0) cycle beta = xland(i)*p_beta_ocean + (1.-xland(i))*p_beta_land q_graup(:) = 0. q_snow(:) = 0. do k = kts, ktop(i) p_liq_ice(k) = FractLiqF(tempco(i, k)) prec_flx_fr = p_liq_ice(k)*prec_flx(i, k)/rho(i, k) q_graup(k) = beta*prec_flx_fr/p_v_graup ! - graupel mixing ratio (kg/kg) q_snow(k) = (1.-beta)*prec_flx_fr/p_v_snow ! - snow mixing ratio (kg/kg) end do k_initial = minloc(abs(tempco(i, kbcon(i):ktop(i)) - p_t_initial), 1) + kbcon(i) - 1 k_final = minloc(abs(tempco(i, kbcon(i):ktop(i)) - p_t_final), 1) + kbcon(i) - 1 q_r = 0.0 do k = k_initial, k_final dz = zo(i, k) - zo(i, k - 1) q_r = q_r + dz*rho(i, k)*(q_graup(k)*(qrco(i, k) + q_snow(k))) !print*,"qr=",q_r,tempco(i,k)-273.15,k,tempco(i,k)-t_initial end do z_base = zo_cup(i, kbcon(i))/1000. ! km !--- !--- lightning flash density (units: number of flashes/km2/day) - equation 5 !--- (to compare with Lopez 2016's results, convert to per year: lightn_dens*365) ! lightn_dens(i) = p_alpha*q_r*sqrt(max(0., cape(i)))*min(z_base, 1.8)**2 ! end do end subroutine cupUpLightning !------------------------------------------------------------------------------------ subroutine getLiqIceNumberConc(itf, ktf, its, ite, kts, kte, ierr, ktop, dtime, rho, outqc, tempco, outnliq, outnice) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getLiqIceNumberConc' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte integer, intent(in) :: ierr(its:ite) integer, intent(in) :: ktop(its:ite) real, intent(in) :: outqc(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: dtime real, intent(out) :: outnliq(its:ite, kts:kte) real, intent(out) :: outnice(its:ite, kts:kte) !Local variables: integer :: i, k real :: fr, tqliq, tqice, dtinv real, dimension(its:ite, kts:kte) :: nwfa !! in the future set this as NCPL real, dimension(its:ite, kts:kte) :: nifa !! in the future set this as NCPI nwfa(:, :) = 99.e7 ! in the future set this as NCPL nifa(:, :) = 0. ! in the future set this as NCPI dtinv = 1./dtime do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktop(i) + 1 fr = FractLiqF(tempco(i, k)) tqliq = dtime*outqc(i, k)*rho(i, k)*fr tqice = dtime*outqc(i, k)*rho(i, k)*(1.-fr) outnice(i, k) = max(0.0, MakeIceNumber(tqice, tempco(i, k))/rho(i, k)) outnliq(i, k) = max(0.0, MakeDropletNumber(tqliq, nwfa(i, k))/rho(i, k)) end do !-- convert in tendencies outnice = outnice*dtinv ! unit [1/s] outnliq = outnliq*dtinv ! unit [1/s] !--- for update ! nwfa =nwfa + outnliq*dtime ! nifa =nifa + outnice*dtime end do end subroutine getLiqIceNumberConc !--------------------------------------------------------------------------------------------------- subroutine cupEnvClevChem(mtp, se_chem, se_cup_chem, ierr, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'cupEnvClevChem' ! Nome da subrotina integer, parameter :: p_clev_option = 2 !! use option 2 !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, mtp integer, intent(in) :: ierr(its:ite) real, intent(in) :: se_chem(mtp, its:ite, kts:kte) real, intent(out) :: se_cup_chem(mtp, its:ite, kts:kte) !Local variables: integer :: i, k if (p_clev_option == 1) then !-- original version do i = its, itf if (ierr(i) /= 0) cycle do k = kts + 1, ktf se_cup_chem(1:mtp, i, k) = 0.5*(se_chem(1:mtp, i, k - 1) + se_chem(1:mtp, i, k)) end do se_cup_chem(1:mtp, i, kts) = se_chem(1:mtp, i, kts) se_cup_chem(1:mtp, i, kte) = se_chem(1:mtp, i, ktf) end do else !-- version 2: se_cup (k+1/2) = se(k) => smoother profiles do i = its, itf if (ierr(i) /= 0) cycle do k = kts, ktf se_cup_chem(1:mtp, i, k) = se_chem(1:mtp, i, k) end do end do end if end subroutine cupEnvClevChem !------------------------------------------------------------------------------------ subroutine getInCloudScChemUp(cumulus, fscav, mtp, se, se_cup, sc_up, pw_up, tot_pw_up_chem & , z_cup, rho, po, po_cup, qrco, tempco, pwo, zuo, up_massentro, up_massdetro & , vvel2d, vvel1d, start_level, k22, kbcon, ktop, klcl, ierr, xland, itf, ktf & , its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getInCloudScChemUp' ! Nome da subrotina real, parameter :: p_scav_eff = 0.6 !! for smoke : Chuang et al. (1992) J. Atmos. Sci. real, parameter :: p_cte_w_upd = 10. !! m/s ! real, parameter :: kc = 5.e-3 !! s-1 real, parameter :: p_kc = 2.e-3 !! autoconversion parameter in GF is lower than what is used in GOCART s-1 !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, mtp integer, intent(in) :: ierr(its:ite) integer, intent(in) :: kbcon(its:ite) integer, intent(in) :: ktop(its:ite) integer, intent(in) :: k22(its:ite) integer, intent(in) :: klcl(its:ite) integer, intent(in) :: start_level(its:ite) real, intent(in) :: fscav(mtp) real, intent(in) :: se(mtp, its:ite, kts:kte) real, intent(in) :: se_cup(mtp, its:ite, kts:kte) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qrco(its:ite, kts:kte) real, intent(in) :: tempco(its:ite, kts:kte) real, intent(in) :: pwo(its:ite, kts:kte) real, intent(in) :: zuo(its:ite, kts:kte) real, intent(in) :: up_massentro(its:ite, kts:kte) real, intent(in) :: up_massdetro(its:ite, kts:kte) real, intent(in) :: po(its:ite, kts:kte) real, intent(in) :: vvel2d(its:ite, kts:kte) real, intent(in) :: vvel1d(its:ite) real, intent(in) :: xland(its:ite) character(len=*), intent(in) :: cumulus real, intent(out) :: sc_up(mtp, its:ite, kts:kte) real, intent(out) :: pw_up(mtp, its:ite, kts:kte) real, intent(out) :: tot_pw_up_chem(mtp, its:ite) !Local variables: real, dimension(mtp, its:ite) :: sc_b real, dimension(mtp) :: conc_mxr real :: x_add, dz, xzz, xzd, xze, denom, henry_coef, w_upd, fliq, dp integer :: i, k, ispc real, dimension(mtp, its:ite, kts:kte) :: factor_temp !--initialization sc_up = se_cup pw_up = 0.0 tot_pw_up_chem = 0.0 if (USE_TRACER_SCAVEN == 2 .and. cumulus /= 'shallow') then factor_temp = 1. do i = its, itf if (ierr(i) /= 0) cycle do ispc = 1, mtp ! - if tracer is type "carbon" then set coefficient to 0 for hydrophobic if (trim(chem_name(ispc) (1:len_trim('OCphobic'))) == 'OCphobic') factor_temp(ispc, :, :) = 0.0 ! - suppress scavenging most aerosols at cold T except BCn1 (hydrophobic), dust, and HNO3 if (trim(chem_name(ispc) (1:len_trim('BCphobic'))) == 'BCphobic') then where (tempco < 258.) factor_temp(ispc, :, :) = 0.0 end if if (trim(chem_name(ispc)) == 'sulfur' .or. & trim(chem_name(ispc) (1:len_trim('ss'))) == 'ss' .or. & ! 'seasalt' trim(chem_name(ispc)) == 'SO2' .or. & trim(chem_name(ispc)) == 'SO4' .or. & trim(chem_name(ispc)) == 'nitrate' .or. & trim(chem_name(ispc)) == 'bromine' .or. & trim(chem_name(ispc)) == 'NH3' .or. & trim(chem_name(ispc)) == 'NH4a') then where (tempco < 258.) factor_temp(ispc, :, :) = 0.0 end if end do end do end if do i = its, itf if (ierr(i) /= 0) cycle !start_level(i) = klcl(i) !start_level(i) = k22(i) do ispc = 1, mtp call getCloudBc(cumulus, kts, kte, ktf, xland(i), po(i, kts:kte), se_cup(ispc, i, kts:kte), sc_b(ispc, i), k22(i)) end do do k = kts, start_level(i) sc_up(:, i, k) = sc_b(:, i) !sc_up (:,i,k) = se_cup(:,i,k) end do end do do i = its, itf if (ierr(i) /= 0) cycle loopk: do k = start_level(i) + 1, ktop(i) + 1 !-- entr,detr, mass flux ... xzz = zuo(i, k - 1) xzd = 0.5*up_massdetro(i, k - 1) xze = up_massentro(i, k - 1) denom = (xzz - xzd + xze) !-- transport + mixing if (denom > 0.) then sc_up(:, i, k) = (sc_up(:, i, k - 1)*xzz - sc_up(:, i, k - 1)*xzd + se(:, i, k - 1)*xze)/denom else sc_up(:, i, k) = sc_up(:, i, k - 1) end if !-- scavenging section if (USE_TRACER_SCAVEN == 0 .or. cumulus == 'shallow') cycle loopk dz = z_cup(i, k) - z_cup(i, k - 1) !-- in-cloud vert velocity for scavenging formulation 2 ! w_upd = cte_w_upd ! w_upd = vvel1d(i) w_upd = vvel2d(i, k) do ispc = 1, mtp if (fscav(ispc) > 1.e-6) then ! aerosol scavenging !--formulation 1 as in GOCART with RAS conv_par if (USE_TRACER_SCAVEN == 1) pw_up(ispc, i, k) = max(0., sc_up(ispc, i, k)*(1.-exp(-fscav(ispc)*(dz/1000.)))) !--formulation 2 as in GOCART if (USE_TRACER_SCAVEN == 2) pw_up(ispc, i, k) = max(0., sc_up(ispc, i, k) * (1.-exp(-chem_adj_autoc(ispc)*p_kc & * (dz/w_upd)))*factor_temp(ispc, i, k)) !--formulation 3 - orignal GF conv_par if (USE_TRACER_SCAVEN == 3) then !--- cloud liquid water tracer concentration conc_mxr(ispc) = p_scav_eff*sc_up(ispc, i, k) !unit [kg(aq)/kg(air)] for aerosol/smoke !--- aqueous-phase concentration in rain water pw_up(ispc, i, k) = conc_mxr(ispc)*pwo(i, k)/(1.e-8 + qrco(i, k)) end if !---(in cloud) total mixing ratio in gas and aqueous phases sc_up(ispc, i, k) = sc_up(ispc, i, k) - pw_up(ispc, i, k) ! elseif (hcts(ispc)%hstar > 1.e-6) then ! tracer gas phase scavenging !--- equilibrium tracer concentration - Henry's law henry_coef = Henry(ispc, tempco(i, k), rho(i, k)) if (USE_TRACER_SCAVEN == 3) then !--- cloud liquid water tracer concentration conc_mxr(ispc) = (henry_coef*qrco(i, k)/(1.+henry_coef*qrco(i, k)))*sc_up(ispc, i, k) ! !--- aqueous-phase concentration in rain water pw_up(ispc, i, k) = conc_mxr(ispc)*pwo(i, k)/(1.e-8 + qrco(i, k)) else !-- this the 'alpha' parameter in Eq 8 of Mari et al (2000 JGR) = X_aq/X_total fliq = henry_coef*qrco(i, k)/(1.+henry_coef*qrco(i, k)) !--- aqueous-phase concentration in rain water pw_up(ispc, i, k) = max(0., sc_up(ispc, i, k) & *(1.-exp(-fliq*chem_adj_autoc(ispc)*p_kc*dz/w_upd)))!*factor_temp(ispc,i,k)) end if !---(in cloud) total mixing ratio in gas and aqueous phases sc_up(ispc, i, k) = sc_up(ispc, i, k) - pw_up(ispc, i, k) ! !---(in cloud) mixing ratio in aqueous phase !sc_up_aq(ispc,i,k) = conc_mxr(ispc) !if using set to zero at the begin. end if end do ! !-- total aerosol/gas in the rain water dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) tot_pw_up_chem(:, i) = tot_pw_up_chem(:, i) + pw_up(:, i, k)*dp/c_grav end do loopk ! !----- get back the in-cloud updraft gas-phase mixing ratio : sc_up(ispc,k) ! do k=start_level(i)+1,ktop(i)+1 ! do ispc = 1,mtp ! sc_up(ispc,i,k) = sc_up(ispc,i,k) - sc_up_aq(ispc,i,k) ! enddo ! enddo end do end subroutine getInCloudScChemUp !--------------------------------------------------------------------------------------------------- subroutine getInCloudScChemDd(cumulus, fscav, mtp, se, se_cup, sc_dn, pw_dn, pw_up, sc_up, tot_pw_up_chem & , tot_pw_dn_chem, z_cup, rho, po_cup, qrcdo, pwdo, pwevo, edto, zdo, dd_massentro & , dd_massdetro, pwavo, pwo , jmin, ierr, itf, ktf, its, ite, kts, kte) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getInCloudScChemDd' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: itf, ktf, its, ite, kts, kte, mtp integer, intent(in) :: ierr(its:ite) integer, intent(in) :: jmin(its:ite) real, intent(in) :: se(mtp, its:ite, kts:kte) real, intent(in) :: se_cup(mtp, its:ite, kts:kte) real, intent(in) :: pw_up(mtp, its:ite, kts:kte) real, intent(in) :: sc_up(mtp, its:ite, kts:kte) real, intent(in) :: fscav(mtp) real, intent(in) :: edto(its:ite) real, intent(in) :: pwavo(its:ite) real, intent(in) :: pwevo(its:ite) real, intent(in) :: z_cup(its:ite, kts:kte) real, intent(in) :: rho(its:ite, kts:kte) real, intent(in) :: po_cup(its:ite, kts:kte) real, intent(in) :: qrcdo(its:ite, kts:kte) real, intent(in) :: pwdo(its:ite, kts:kte) real, intent(in) :: zdo(its:ite, kts:kte) real, intent(in) :: dd_massentro(its:ite, kts:kte) real, intent(in) :: dd_massdetro(its:ite, kts:kte) real, intent(in) :: pwo(its:ite, kts:kte) real, intent(in) :: tot_pw_up_chem(mtp, its:ite) character(len=*), intent(in) :: cumulus real, intent(out) :: sc_dn(mtp, its:ite, kts:kte) real, intent(out) :: pw_dn(mtp, its:ite, kts:kte) real, intent(out) :: tot_pw_dn_chem(mtp, its:ite) !Local variables: real, dimension(mtp) :: conc_mxr real :: x_add, dz, xzz, xzd, xze, denom, evaporate, pwdper, x1, frac_evap, dp, xkk integer :: i, k, ispc sc_dn = 0.0 pw_dn = 0.0 tot_pw_dn_chem = 0.0 if (cumulus == 'shallow') return do i = its, itf if (ierr(i) /= 0) cycle !--- fration of the total rain that was evaporated frac_evap = -pwevo(i)/(1.e-16 + pwavo(i)) !--- scalar concentration in-cloud - downdraft !--- at k=jmim k = jmin(i) pwdper = pwdo(i, k)/(1.e-16 + pwevo(i))*frac_evap ! > 0 if (USE_TRACER_EVAP == 0) pwdper = 0.0 dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) do ispc = 1, mtp !--downdrafts will be initiate with a mixture of 50% environmental and in-cloud concentrations sc_dn(ispc, i, k) = se_cup(ispc, i, k) !sc_dn(ispc,i,k) = 0.9*se_cup(ispc,i,k)+0.1*sc_up(ispc,i,k) pw_dn(ispc, i, k) = -pwdper*tot_pw_up_chem(ispc, i)*c_grav/dp sc_dn(ispc, i, k) = sc_dn(ispc, i, k) - pw_dn(ispc, i, k) tot_pw_dn_chem(ispc, i) = tot_pw_dn_chem(ispc, i) + pw_dn(ispc, i, k)*dp/c_grav end do ! !--- calculate downdraft mass terms do k = jmin(i) - 1, kts, -1 xzz = zdo(i, k + 1) xzd = 0.5*dd_massdetro(i, k) xze = dd_massentro(i, k) denom = (xzz - xzd + xze) !-- transport + mixing if (denom > 0.) then sc_dn(:, i, k) = (sc_dn(:, i, k + 1)*xzz - sc_dn(:, i, k + 1)*xzd + se(:, i, k)*xze)/denom else sc_dn(:, i, k) = sc_dn(:, i, k + 1) end if ! !-- evaporation term if (USE_TRACER_EVAP == 0) cycle dp = 100.*(po_cup(i, k) - po_cup(i, k + 1)) !-- fraction of evaporated precip per layer pwdper = pwdo(i, k)/(1.e-16 + pwevo(i))! > 0 !-- fraction of the total precip that was actually evaporated at layer k pwdper = pwdper*frac_evap !-- sanity check pwdper = min(1., max(pwdper, 0.)) do ispc = 1, mtp !-- amount evaporated by the downdraft from the precipitation pw_dn(ispc, i, k) = -pwdper*tot_pw_up_chem(ispc, i)*c_grav/dp ! < 0. => source term for the downdraft tracer concentration !if(ispc==1) print*,"pw=",pwdper,tot_pw_up_chem (ispc,i),pwevo(i)/pwavo(i),pwdo(i,k)/(1.e-16+pwo(i,k)) !-- final tracer in the downdraft sc_dn(ispc, i, k) = sc_dn(ispc, i, k) - pw_dn(ispc, i, k) ! observe that -pw_dn is > 0. !-- total evaporated tracer tot_pw_dn_chem(ispc, i) = tot_pw_dn_chem(ispc, i) + pw_dn(ispc, i, k)*dp/c_grav !print*,"to=",k,tot_pw_dn_chem(ispc,i),pwdo(i,k)/(1.e-16+pwevo(i)),frac_evap,tot_pw_dn_chem(ispc,i)/tot_pw_up_chem (ispc,i) end do end do ! end do end subroutine getInCloudScChemDd !--------------------------------------------------------------------------------------------------- subroutine setGradsVar(i_in, k_in, nvar, f_in, name1, name2, name3) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'setGradsVar' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: i_in, k_in real, intent(in) :: f_in character(len=*), intent(in) :: name1 character(len=*), intent(in) :: name2 character(len=*), intent(in) :: name3 integer, intent(inout) :: nvar cupout(nvar)%varp(i_in, k_in) = f_in cupout(nvar)%varn(1) = name1 cupout(nvar)%varn(2) = name2 cupout(nvar)%varn(3) = name3 nvar = nvar + 1 if (nvar > p_nvar_grads) stop 'nvar>nvar_grads' end subroutine setGradsVar !------------------------------------------------------------------------------------ subroutine wrtBinCtl(n, mzp, p2d, cumulus) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'wrtBinCtl' ! Nome da subrotina real, parameter :: p_undef = -9.99e33 !Variables (input, output, inout) integer, intent(in):: n, mzp real, intent(in) :: p2d(mzp) character(len=*), intent(in) :: cumulus !Local variables: integer:: nvartotal, klevgrads(200), jk, int_byte_size, nvar, maxklevgrads real :: real_byte_size integer :: nrec = 0 integer :: rec_size maxklevgrads = min(60, mzp) runname = '15geos5_'//cumulus runlabel = runname print *, "writing grads control file:',trim(runname)//'.ctl", ntimes call flush (6) ! !number of variables to be written nvartotal = 0 do nvar = 1, p_nvar_grads if (cupout(nvar)%varn(1) .ne. "xxxx") nvartotal = nvartotal + 1 if (cupout(nvar)%varn(3) == "3d") klevgrads(nvar) = maxklevgrads if (cupout(nvar)%varn(3) == "2d") klevgrads(nvar) = 1 end do !- binary file inquire (iolength=int_byte_size) real_byte_size ! inquire by output list print *, 'opening grads file:', trim(runname)//'.gra' rec_size = size(cupout(nvar)%varp, 1)*real_byte_size if (ntimes == 1) then open (19, file=trim(runname)//'.gra', form='unformatted', & access='direct', status='replace', recl=rec_size) else open (19, file=trim(runname)//'.gra', form='unformatted', & access='direct', status='old', recl=rec_size) end if do nvar = 1, p_nvar_grads if (cupout(nvar)%varn(1) .ne. "xxxx") then do jk = 1, klevgrads(nvar) nrec = nrec + 1 !write(19) real((cupout(nvar)%varp(:,jk)),4) write (19, rec=nrec) real((cupout(nvar)%varp(:, jk)), 4) end do end if end do close (19) !-setting vertical dimension '0' for 2d var where (klevgrads == 1) klevgrads = 0 !- ctl file open (20, file=trim(runname)//'.ctl', status='unknown') write (20, 2001) '^'//trim(runname)//'.gra' write (20, 2002) 'undef -9.99e33' write (20, 2002) 'options sequential byteswapped' ! zrev' write (20, 2002) 'title '//trim(runlabel) write (20, 2003) 1, 0., 1. ! units m/km write (20, 2004) n, 1., 1. write (20, 2005) maxklevgrads, (p2d(jk), jk=1, maxklevgrads) write (20, 2006) ntimes, '00:00Z24JAN1999', '10mn' write (20, 2007) nvartotal do nvar = 1, p_nvar_grads if (cupout(nvar)%varn(1) .ne. "xxxx") then ! write (20, 2008) cupout(nvar)%varn(1) (1:len_trim(cupout(nvar)%varn(1))), klevgrads(nvar) & , cupout(nvar)%varn(2) (1:len_trim(cupout(nvar)%varn(2))) end if end do write (20, 2002) 'endvars' close (20) 2001 format('dset ', a) 2002 format(a) 2003 format('xdef ', i4, ' linear ', 2f15.3) 2004 format('ydef ', i4, ' linear ', 2f15.3) 2005 format('zdef ', i4, ' levels ', 60f8.3) 2006 format('tdef ', i4, ' linear ', 2a15) 2007 format('vars ', i4) 2008 format(a10, i4, ' 99 ', a40)!'[',a8,']') 2055 format(60f7.0) 133 format(1x, F7.0) end subroutine wrtBinCtl !------------------------------------------------------------------------------------ subroutine getInterp(q_old, t_old, po_cup, q_new, t_new) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'getInterp' ! Nome da subrotina !Variables (input, output, inout) real, intent(in) :: po_cup !! original real, intent(inout) :: q_old real, intent(inout) :: t_old real, intent(inout) :: q_new real, intent(inout) :: t_new !! extrapolated !Local variables: real :: zqp, zcond1, zcor, zqsat real :: psp, pt, pq, ptare real :: foealfcu, foeewmcu, foedemcu, foeldcpmcu integer :: i pt = t_old ! K pq = q_old ! kg/kg psp = po_cup*100. ! hPa !-- for testing ! PSP TEMP Q ZCOND1 ! input 27940.0000000000 236.604976804749 3.220181796223121E-004 ! output 27940.0000000000 236.361132108860 4.084506812610067E-004 ! PT = 236.604976804749 ! K ! PQ = 3.220181796223121E-004 ! kg/kg ! PSP = 27940. ! hPa !---------------------- !print*,"1",PSP,PT,PQ zqp = 1.0/psp do i = 1, 2 ptare = pt foealfcu = min(1.0, ((max(c_rtice, min(c_t00, ptare)) - c_rtice)*c_rtwat_rtice_r)**2) foeewmcu = c_r2es*(foealfcu*exp(c_r3les*(ptare - c_t00)/(ptare - c_r4les)) + (1.0 - foealfcu)*exp(c_r3ies*(ptare - c_t00) & / (ptare - c_r4ies))) zqsat = foeewmcu*zqp ! if(1.0-RETV *ZQSAT == 0.) then ! ! print*,"ZQSAT=",ZQP,FOEEWMCU,q_old,t_old,po_cup,q_new,t_new !3.5491847E-02 46.36052 0.5000000 249.8219 ! 0.2817549 0.5000000 249.8219 ! call flush(6) ! stop 3333 ! endif zcor = 1.0/(1.0 - c_retv*zqsat) zqsat = zqsat*zcor foedemcu = foealfcu*c_r5alvcp*(1.0/(ptare - c_r4les)**2) + (1.0 - foealfcu)*c_r5alscp*(1.0/(ptare - c_r4ies)**2) zcond1 = (pq - zqsat)/(1.0 + zqsat*zcor*foedemcu) foeldcpmcu = foealfcu*c_ralvdcp + (1.0 - foealfcu)*c_ralsdcp pt = pt + foeldcpmcu*zcond1 pq = pq - zcond1 end do !-- FINAL -------------------------- q_new = pq t_new = pt !print*,"2",PSP,PT,PQ !print*,"E",100*(PT-236.361132108860)/236.361132108860,100*(PQ-4.084506812610067E-004)/4.084506812610067E-004 end subroutine getInterp !------------------------------------------------------------------------------------ function SatVap(temp2) result(r_sat_vap) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'SatVap' ! Nome da função !Variables (input): real, intent(in) :: temp2 !Local variables: real :: r_sat_vap !Output real :: temp, toot, toto, eilog, tsot, & ewlog, ewlog2, ewlog3, ewlog4 temp = temp2 - 273.155 if (temp .lt. -20.) then !!!! ice saturation toot = 273.16/temp2 toto = 1/toot eilog = -9.09718*(toot - 1) - 3.56654*(log(toot) / log(10.)) + .876793*(1 - toto) + (log(6.1071)/log(10.)) r_sat_vap = 10**eilog else tsot = 373.16/temp2 ewlog = -7.90298*(tsot - 1) + 5.02808* & (log(tsot)/log(10.)) ewlog2 = ewlog - 1.3816e-07* & (10**(11.344*(1 - (1/tsot))) - 1) ewlog3 = ewlog2 + .0081328* & (10**(-3.49149*(tsot - 1)) - 1) ewlog4 = ewlog3 + (log(1013.246)/log(10.)) r_sat_vap = 10**ewlog4 end if end function SatVap !------------------------------------------------------------------------------------ function Td(p, rs) result(r_td) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'Td' ! Nome da função !Variables (input): real, intent(in) :: p real, intent(in) :: rs !Local variables: real :: r_td !output real :: rr, es, esln rr = rs + 1e-8 es = p*rr/(.622 + rr) esln = log(es) r_td = (35.86*esln - 4947.2325)/(esln - 23.6837) end function Td !--------------------------------------------------------------------------------------------------- function Henry(ispc, temp, rhoair) result(henry_coef) !! calculate Henry's constant !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! calculate Henry's constant for solubility of gases into cloud water !!inputs : ak0(ispc), dak(ispc), hstar(ispc), dhr(ispc) !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'henry' ! Nome da função !Variables (input): integer, intent(in) :: ispc real, intent(in) :: temp real, intent(in) :: rhoair !Local variables: real :: henry_coef ! output real :: fct, tcorr, corrh ! aqueous-phase concentrations XXXa [mol/m3(air)]! ! gas-phase concentrations XXXg [mol/m3(air)]! ! Henry constants XXXh for scavenging [mol/(l*atm)]! ! converted to [(mol(aq)/m3(aq))/(mol(g)/m3(air))], i.e. dimensionless! ! in equilibrium XXXa = XXXh * LWC * XXXg! tcorr = 1./temp - c_temp0i !-P. Colarco corrected the expression below !fct = conv7 * rgas_ * temp ! - for henry_coef in units 1/m3 fct = c_rgas_*temp ! - for henry_coef dimensioless !-taking into account the acid dissociation constant ! ak=ak0*exp(dak*(1/t-1/298)) corrh = 1.+hcts(ispc)%ak0*exp(hcts(ispc)%dak*tcorr)/c_hplus !-- for concentration in mol[specie]/mol[air] - Eq 5 in 'Compilation of Henry's law constants (version 4.0) for !-- water as solvent, R. Sander, ACP 2015'. henry_coef = hcts(ispc)%hstar*exp(hcts(ispc)%dhr*tcorr)*fct*corrh end function Henry !------------------------------------------------------------------------------------ function SaturSpecHum(pt, press) result(pqsat) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'SaturSpecHum' ! Nome da função !Variables (input): real, intent(in) :: pt !! kelvin real, intent(in) :: press !! hPa !Local variables: real :: pqsat !output real :: zew, zqs, zcor, foealfcu, foeewmcu foealfcu = min(1.0, ((max(c_rtIce, min(c_t00, pt)) - c_rtIce)*c_rtwat_rtIce_r)**2) foeewmcu = c_r2es*(foealfcu*exp(c_r3les*(pt - c_t00)/(pt - c_r4les)) + (1.0 - foealfcu)*exp(c_r3ies*(pt - c_t00) & / (pt - c_r4ies))) zew = foeewmcu zqs = zew/(100.*press) if (1.0 - c_retv*zqs > 0.) then zcor = 1.0/(1.0 - c_retv*zqs) ! divide by zero pqsat = zqs*zcor else pqsat = c_max_qsat end if end function SaturSpecHum !------------------------------------------------------------------------------------ function FractLiqF(temp2) result(r_fract_liq_f) !! brief !! !! @note !! !! **Project**: MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'FractLiqF' ! Nome da função real, parameter :: p_max_temp = 46. !! Celsius !Variables (input): real, intent(in) :: temp2 !! K !Local variables: real :: r_fract_liq_f !Output real :: temp, ptc select case (FRAC_MODIS) case (1) temp = temp2 - 273.16 !Celsius temp = min(p_max_temp, max(-p_max_temp, temp)) ptc = 7.6725 + 1.0118*temp + 0.1422*temp**2 + 0.0106*temp**3 + 3.39e-4*temp**4 + 3.95e-6*temp**5 r_fract_liq_f = 1./(1.+exp(-ptc)) !WMP skew ice fraction for deep convective clouds ! fract_liq_f = fract_liq_f**4 !WMP case default r_fract_liq_f = min(1., (max(0., (temp2 - c_t_ice))/(c_t_0 - c_t_ice))**2) end select end function subroutine gfConparInit(mynum) !! Read the namelist !! !! @note !! !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! Read the namelist !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'gfConparInit' ! Nome da subrotina !Variables (input, output, inout) integer, intent(in) :: mynum !!Number of current processor !Local variables: character(len=64) :: fn_nml = 'GF_ConvPar_nml' logical :: exists integer :: nlunit = 4 !Code: namelist /GF_NML/ ICUMULUS_GF, CLOSURE_CHOICE, USE_SCALE_DEP, DICYCLE & , USE_TRACER_TRANSP, USE_TRACER_SCAVEN, USE_FLUX_FORM, USE_TRACER_EVAP, DOWNDRAFT, USE_FCT & , USE_REBCB, VERT_DISCR, SATUR_CALC, CLEV_GRID, APPLY_SUB_MP, ALP1 & , SGS_W_TIMESCALE, LIGHTNING_DIAG, AUTOCONV, BC_METH, OVERSHOOT, USE_WETBULB & , C1, C0_DEEP, QRC_CRIT, LAMBAU_DEEP, LAMBAU_SHDN, C0_MID & , CUM_MAX_EDT_LAND, CUM_MAX_EDT_OCEAN, CUM_HEI_DOWN_LAND & , CUM_HEI_DOWN_OCEAN, CUM_HEI_UPDF_LAND, CUM_HEI_UPDF_OCEAN & , CUM_ENTR_RATE, TAU_DEEP, TAU_MID & , USE_MOMENTUM_TRANSP, MOIST_TRIGGER, FRAC_MODIS & , CUM_USE_EXCESS, CUM_AVE_LAYER, ADV_TRIGGER, USE_SMOOTH_PROF & , USE_CLOUD_DISSIPATION, USE_SMOOTH_TEND, USE_GUSTINESS, USE_RANDOM_NUM & , DCAPE_THRESHOLD, BETA_SH, C0_SHAL, USE_LINEAR_SUBCL_MF, LIQ_ICE_NUMBER_CONC & , ALPHA_ADV_TUNING, CAP_MAXS, SIG_FACTOR, CUM_FADJ_MASSFLX, LCL_TRIGGER & , RH_DICYCLE, CUM_T_STAR, CONVECTION_TRACER, TAU_OCEA_CP, TAU_LAND_CP & , USE_MEMORY, ADD_COLDPOOL_PROP, MX_BUOY1, MX_BUOY2, MAX_TQ_TEND, CUM_ZUFORM & , ADD_COLDPOOL_CLOS, ADD_COLDPOOL_DIFF inquire (file=trim(fn_nml), exist=exists) if (.not. exists) then write (6, *) 'GF_convpar_nml :: namelist file: ', trim(fn_nml), ' does not exist' stop 31415 else open (nlunit, file=fn_nml, status='old', form='formatted') read (nlunit, nml=GF_NML) close (nlunit) end if if (mynum == 1) then !- print the namelist print *, " " print *, "------------- GF ConvPar namelist -------------" print *, "!---- the main controls" print *, 'icumulus_gf ', ICUMULUS_GF print *, 'cum_entr ', real(CUM_ENTR_RATE, 4) print *, 'closure_choice ', CLOSURE_CHOICE print *, 'use_scale_dep ', USE_SCALE_DEP print *, 'sig_factor ', real(SIG_FACTOR, 4) print *, 'dicycle ', DICYCLE print *, 't_star ', real(CUM_T_STAR, 4) print *, 'rh_dicycle ', RH_DICYCLE print *, 'alpha_adv_tuning ', real(ALPHA_ADV_TUNING, 4) print *, 'cap_maxs ', real(CAP_MAXS, 4) print *, 'moist_trigger ', MOIST_TRIGGER print *, 'adv_trigger ', ADV_TRIGGER print *, 'lcl_trigger ', LCL_TRIGGER print *, 'dcape_threshold ', real(DCAPE_THRESHOLD, 4) print *, 'tau_deep,tau_mid ', real(TAU_DEEP, 4), real(TAU_MID, 4) print *, 'SGS_W_TIMESCALE ', SGS_W_TIMESCALE print *, 'CONVECTION_TRACER ', CONVECTION_TRACER print *, 'ADD_COLDPOOL_PROP ', ADD_COLDPOOL_PROP print *, 'ADD_COLDPOOL_CLOS ', ADD_COLDPOOL_CLOS print *, 'ADD_COLDPOOL_DIFF ', ADD_COLDPOOL_DIFF print *, 'tau_ocea_cp ', TAU_OCEA_CP print *, 'tau_land_cp ', TAU_LAND_CP print *, 'mx_buoy1 - kJ/kg ', MX_BUOY1*1.e-3 print *, 'mx_buoy2 - kJ/kg ', MX_BUOY2*1.e-3 print *, 'USE_MEMORY ', USE_MEMORY print *, '!--- controls rainfall evaporation' print *, 'USE_REBCB ', USE_REBCB print *, 'downdraft ', DOWNDRAFT print *, 'max_edt_land ', real(CUM_MAX_EDT_LAND, 4) print *, 'max_edt_ocean ', real(CUM_MAX_EDT_OCEAN, 4) print *, '!---- boundary condition specification' print *, 'BC_METH ', BC_METH print *, 'cum_use_excess ', CUM_USE_EXCESS print *, 'cum_ave_layer ', real(CUM_AVE_LAYER, 4) print *, '!---- for mass flux profiles - (deep ,shallow ,congestus)' print *, 'CUM_ZUFORM ', CUM_ZUFORM print *, 'hei_down_land ', real(CUM_HEI_DOWN_LAND, 4) print *, 'hei_down_ocean ', real(CUM_HEI_DOWN_OCEAN, 4) print *, 'hei_updf_land ', real(CUM_HEI_UPDF_LAND, 4) print *, 'hei_updf_ocean ', real(CUM_HEI_UPDF_OCEAN, 4) print *, 'beta_sh ', real(BETA_SH, 4) print *, 'use_linear_subcl_mf', USE_LINEAR_SUBCL_MF print *, 'use_smooth_prof ', USE_SMOOTH_PROF print *, 'use_smooth_tend ', USE_SMOOTH_TEND print *, 'use_random_num ', USE_RANDOM_NUM print *, '!---- the cloud microphysics' print *, 'AUTOCONV ', AUTOCONV print *, 'C0_DEEP ', real(C0_DEEP, 4) print *, 'C0_MID ', real(C0_MID, 4) print *, 'C0_SHAL ', real(C0_SHAL, 4) print *, 'c1 ', real(C1, 4) print *, 'QRC_CRIT ', real(QRC_CRIT, 4) print *, '!--- for momentum transport' PRINT *, 'USE_MOMENTUM_TRANS ', USE_MOMENTUM_TRANSP print *, 'lambau_deep ', real(LAMBAU_DEEP, 4) print *, 'lambau_shdn ', real(LAMBAU_SHDN, 4) print *, '!--- for tracer transport' print *, 'USE_TRACER_TRANSP ', USE_TRACER_TRANSP print *, 'USE_TRACER_SCAVEN ', USE_TRACER_SCAVEN print *, 'USE_FLUX_FORM ', USE_FLUX_FORM print *, 'use_fct ', USE_FCT print *, 'use_tracer_evap ', USE_TRACER_EVAP print *, 'apply_sub_mp ', APPLY_SUB_MP print *, 'ALP1 ', real(ALP1, 4) print *, '!---- couplings w/ other parameterizations' print *, 'LIGHTNING_DIAG ', LIGHTNING_DIAG print *, 'OVERSHOOT ', real(OVERSHOOT, 4) print *, 'liq_ice_number_conc', LIQ_ICE_NUMBER_CONC print *, 'use_gustiness ', USE_GUSTINESS print *, '!----misc controls' print *, 'frac_modis ', FRAC_MODIS print *, 'use_cloud_dissipat ', real(USE_CLOUD_DISSIPATION, 4) print *, 'USE_WETBULB ', USE_WETBULB print *, 'CLEV_GRID ', CLEV_GRID print *, 'vert_discr ', VERT_DISCR print *, 'satur_calc ', SATUR_CALC print *, 'max_tq_tend ', real(MAX_TQ_TEND, 4) print *, 'cum_fadj_massflx ', real(CUM_FADJ_MASSFLX, 4) print *, "========================================================================" call flush (6) end if end subroutine gfConparInit !----------------------------------------------------------------------- function MakeIceNumber(q_ice, temp) result(ice_number) !! number_concentrations !! !! @note !! !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !!-! ---- module_mp_thompson_make_number_concentrations !!-! Developed by H. Barnes @ NOAA/OAR/ESRL/GSL Earth Prediction Advancement Division !! !! Q_ice is cloud ice mixing ratio, units of kg/m3 !! Q_cloud is cloud water mixing ratio, units of kg/m3 !! Q_rain is rain mixing ratio, units of kg/m3 !! temp is air temperature in Kelvin !! make_IceNumber is cloud droplet number mixing ratio, units of number per m3 !! MakeDropletNumber is rain number mixing ratio, units of number per kg of m3 !! make_RainNumber is rain number mixing ratio, units of number per kg of m3 !! qnwfa is number of water-friendly aerosols in number per kg !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'MakeIceNumber' ! Nome da função real, parameter:: c_ice_density = 890.0 !Variables (input): real, intent(in) :: q_ice real, intent(in) :: temp !Local variables: real :: ice_number ! output integer :: idx_rei real :: corr, reice, deice double precision :: lambda !+---+-----------------------------------------------------------------+ !..Table of lookup values of radiative effective radius of ice crystals !.. as a function of Temperature from -94C to 0C. Taken from WRF RRTMG !.. radiation code where it is attributed to Jon Egill Kristjansson !.. and coauthors. !+---+-----------------------------------------------------------------+ real, dimension(95), parameter:: p_retab = (/ & 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/) if (q_ice == 0) then ice_number = 0 return end if !+---+-----------------------------------------------------------------+ !..From the model 3D temperature field, subtract 179K for which !.. index value of retab as a start. Value of corr is for !.. interpolating between neighboring values in the table. !+---+-----------------------------------------------------------------+ idx_rei = int(temp - 179.) idx_rei = min(max(idx_rei, 1), 94) corr = temp - int(temp) reice = p_retab(idx_rei)*(1.-corr) + p_retab(idx_rei + 1)*corr deice = 2.*reice*1.e-6 !+---+-----------------------------------------------------------------+ !..Now we have the final radiative effective size of ice (as function !.. of temperature only). This size represents 3rd moment divided by !.. second moment of the ice size distribution, so we can compute a !.. number concentration from the mean size and mass mixing ratio. !.. The mean (radiative effective) diameter is 3./Slope for an inverse !.. exponential size distribution. So, starting with slope, work !.. backwords to get number concentration. !+---+-----------------------------------------------------------------+ lambda = 3.0/deice ice_number = q_ice*lambda*lambda*lambda/(c_pi*c_ice_density) !+---+-----------------------------------------------------------------+ !..Example1: Common ice size coming from Thompson scheme is about 30 microns. !.. An example ice mixing ratio could be 0.001 g/kg for a temperature of -50C. !.. Remember to convert both into MKS units. This gives N_ice=357652 per kg. !..Example2: Lower in atmosphere at T=-10C matching ~162 microns in retab, !.. and assuming we have 0.1 g/kg mixing ratio, then N_ice=28122 per kg, !.. which is 28 crystals per liter of air if the air density is 1.0. !+---+-----------------------------------------------------------------+ end function MakeIceNumber !------------------------------------------------------------------------------ function MakeDropletNumber(q_cloud, qnwfa) result(droplet_number) !! brief !! !! @note !! !! **Project** : MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'MakeDropletNumber' ! Nome da função real, parameter:: c_am_r = c_pi*1000./6. real, dimension(15), parameter:: c_g_ratio = (/24, 60, 120, 210, 336, 504, 720, 990, 1320, 1716, 2184, 2730, 3360, 4080 & , 4896/) !Variables (input): real, intent(in):: q_cloud real, intent(in):: qnwfa !Local variables: real :: droplet_number ! out double precision:: lambda, qnc real:: q_nwfa, x1, xDc integer:: nu_c if (Q_cloud == 0) then droplet_number = 0 return end if q_nwfa = max(99.e6, min(qnwfa, 5.e10)) nu_c = max(2, min(nint(2.5e10/q_nwfa), 15)) x1 = max(1., min(q_nwfa*1.e-9, 10.)) - 1. xDc = (30.-x1*20./9.)*1.e-6 lambda = (4.0d0 + nu_c)/xDc qnc = Q_cloud/c_g_ratio(nu_c)*lambda*lambda*lambda/c_am_r droplet_number = SNGL(qnc) return end function MakeDropletNumber !---------------------------------------------------------------------------------------- pure function IntFuncGamma(x, y) result(z) !! brief !! !! @note !! !! **Project** : MONAN !! **Author(s)**: Demerval Moreira [DSM] !! **e-mail**: <mailto:demerval.moreira@unesp.br> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'IntFuncGamma' ! Nome da função !Variables (input): real, intent(in) :: x real, intent(in) :: y !Local variables: real :: z ! output !Code: z = x**(y - 1.0)*exp(-x) end function IntFuncGamma !--------------------------------------------------------------------------------------------- function GammaBrams(a) result(g) !! brief !! !! @note !! !! **Project** : MONAN !! **Author(s)**: Demerval Moreira [DSM] !! **e-mail**: <mailto:demerval.moreira@unesp.br> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'GammaBrams' ! Nome da função real, parameter :: p_small = 1.0e-4 integer, parameter :: p_points = 100000 !Variables (input): real, intent(in) :: a !Local variables: real :: g !Output real :: infty, dx, p, sp(2, p_points), x integer :: i logical :: correction x = a correction = .false. ! value with x<1 gives \infty, so we use ! \Gamma(x+1) = x\Gamma(x) ! to avoid the problem if (x < 1.0) then correction = .true. x = x + 1 end if ! find a "reasonable" infinity... ! we compute this integral indeed ! \int_0^M dt t^{x-1} e^{-t} ! where M is such that M^{x-1} e^{-M} ≤ \epsilon infty = 1.0e4 do while (IntFuncGamma(infty, x) > p_small) infty = infty*10.0 end do ! using simpson dx = infty/real(p_points) sp = 0.0 forall (i=1:p_points/2 - 1) sp(1, 2*i) = IntFuncGamma(2.0*(i)*dx, x) forall (i=1:p_points/2) sp(2, 2*i - 1) = IntFuncGamma((2.0*(i) - 1.0)*dx, x) g = (IntFuncGamma(0.0, x) + 2.0*sum(sp(1, :)) + 4.0*sum(sp(2, :)) + & IntFuncGamma(infty, x))*dx/3.0 if (correction) g = g/a end function GammaBrams !------------------------------------------------------------------------------------------ function Ran1(idum) result(random_number) !! Random number generator !! !! @note !! !! **Project** : MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! This is contributed code standardized by Yong Wang !! Random number generator taken from Press et al. !! !! Returns numbers in the range 0-->1 !! !! Their description... !! "Minimal" random number generator of Park and Miller with Bays-Durham !! shuffle and added safeguards. Returns a uniform deviate between 0.0 and 1.0 !! (exclusive of the endpoint values). Call with idum a negative integer to !! initialize; thereafter, do not alter idum between successive calls in a !! sequence. RNMX should approximate the largest floating value that is less !! than 1. !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'Ran1' ! Nome da função integer(8), parameter:: p_ntab = 32 integer(8), parameter:: p_iq = 127773 integer(8), parameter:: p_ia = 16807 integer(8), parameter:: p_ir = 2836 integer(8), parameter:: p_im = 2147483647 integer(8), parameter:: p_ndiv = 1 + (p_im - 1)/p_ntab real(8), parameter:: p_am = 1.0/p_im real(8), parameter:: p_eps = 1.2e-7 real(8), parameter:: p_rnmx = 1.0 - p_eps !Variables (input): integer(8), intent(inout):: idum !Local variables: real(8) :: random_number !output integer(8):: iy integer(8), dimension(p_ntab):: iv !save iv,iy data iv/p_ntab*0/, iy/0/ integer(8):: j, k if (idum .le. 0 .or. iy .eq. 0) then ! initialize idum = max(-idum, 1) do j = p_ntab + 8, 1, -1 k = idum/p_iq idum = p_ia*(idum - k*p_iq) - p_ir*k if (idum .lt. 0) idum = idum + p_im if (j .le. p_ntab) iv(j) = idum end do iy = iv(1) end if ! k = idum/p_iq ! compute idum = mod(ia*idum,im) without overflows by schrage's method idum = p_ia*(idum - k*p_iq) - p_ir*k if (idum .lt. 0) idum = idum + p_im ! j will be in the range 1-->ntab j = 1 + iy/p_ndiv ! output previously stored value and refill the shuffle table iy = iv(j) iv(j) = idum random_number = min(p_am*iy, p_rnmx) end function Ran1 !------------------------------------------------------------------------------------ function ColdPoolStart(cnv_tr) result(cp_start_out) !! brief !! !! @note !! !! **Project** : MONAN !! **Author(s)**: Saulo Freitas [SRF] e Georg Grell [GAG] !! **e-mail**: <mailto:saulo.r.de.freitas@gmail.com>, <mailto:georg.a.grell@noaa.gov> !! **Date**: 2014 !! !! **Full description**: !! brief !! !! @endnote !! !! @warning !! !! [](https://www.gnu.org/graphics/gplv3-127x51.png'') !! !! Under the terms of the GNU General Public version 3 !! !! @endwarning implicit none !Parameters: character(len=*), parameter :: procedureName = 'ColdPoolStart' ! Nome da função real, parameter :: p_width = 100. !! orig 100 !Variables (input): real, intent(in) :: cnv_tr !Local variables: real :: cp_start_out !output real :: f1 f1 = min(MX_BUOY2, cnv_tr) !--- f1 > mx_buoy1 => cp_start_out ---> 1 cp_start_out = (1.35 + atan((f1 - mx_buoy1)/p_width))/2.8 cp_start_out = max(0.00, min(cp_start_out, 1.00)) !cp_start_out = max(0.05,min(cp_start_out,0.95)) end function ColdPoolStart end module modConvParGF